[squeak-dev] Squeak 4.5: SUnit-fbs.99.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 24 20:24:28 UTC 2014
Chris Muller uploaded a new version of SUnit to project Squeak 4.5:
http://source.squeak.org/squeak45/SUnit-fbs.99.mcz
==================== Summary ====================
Name: SUnit-fbs.99
Author: fbs
Time: 9 January 2014, 2:05:18.527 pm
UUID: a5be81dd-6e9f-8d41-a091-3c6c27a28abe
Ancestors: SUnit-cmm.98
Basic #assert:identical: implementation.
Suggestions for a better error message welcome!
==================== Snapshot ====================
SystemOrganization addCategory: #'SUnit-Extensions'!
SystemOrganization addCategory: #'SUnit-Kernel'!
SystemOrganization addCategory: #'SUnit-Tests'!
Exception subclass: #TestFailure
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
!TestFailure commentStamp: '<historical>' prior: 0!
Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...!
TestFailure subclass: #ResumableTestFailure
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
!ResumableTestFailure commentStamp: '<historical>' prior: 0!
A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass.
here''s an example:
(1 to: 30) do: [ :each |
self assert: each odd description: each printString, ' is even' resumable: true]
for each element where #odd returns <false>, the element will be printed to the Transcript. !
----- Method: ResumableTestFailure>>isResumable (in category 'camp smalltalk') -----
isResumable
"Of course a ResumableTestFailure is resumable ;-)"
^true!
----- Method: ResumableTestFailure>>sunitExitWith: (in category 'camp smalltalk') -----
sunitExitWith: aValue
self resume: aValue!
----- Method: TestFailure>>defaultAction (in category 'camp smalltalk') -----
defaultAction
Processor activeProcess
debug: self signalerContext
title: self description!
----- Method: TestFailure>>isResumable (in category 'camp smalltalk') -----
isResumable
^ false!
Object subclass: #ClassFactoryForTestCase
instanceVariableNames: 'createdClasses'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Extensions'!
----- Method: ClassFactoryForTestCase>>cleanUp (in category 'cleaning') -----
cleanUp
| createdClassNames |
createdClassNames := self createdClassNames.
self deleteClasses.
self deletePackage.
self cleanUpChangeSetForClassNames: createdClassNames.
self createdClasses: IdentitySet new!
----- Method: ClassFactoryForTestCase>>cleanUpChangeSetForClassNames: (in category 'cleaning') -----
cleanUpChangeSetForClassNames: classeNames
| changeSet |
changeSet := ChangeSet current.
classeNames do: [:name|
changeSet
removeClassChanges: name;
removeClassChanges: name, ' class']. !
----- Method: ClassFactoryForTestCase>>createdClassNames (in category 'accessing') -----
createdClassNames
^self createdClasses collect: [:class| class name]!
----- Method: ClassFactoryForTestCase>>createdClasses (in category 'accessing') -----
createdClasses
^createdClasses!
----- Method: ClassFactoryForTestCase>>createdClasses: (in category 'accessing') -----
createdClasses: classes
createdClasses := classes asIdentitySet !
----- Method: ClassFactoryForTestCase>>defaultCategory (in category 'accessing') -----
defaultCategory
^ (self packageName , '-', self defaultCategoryPostfix) asSymbol!
----- Method: ClassFactoryForTestCase>>defaultCategoryPostfix (in category 'accessing') -----
defaultCategoryPostfix
^ #Default!
----- Method: ClassFactoryForTestCase>>delete: (in category 'cleaning') -----
delete: aClass
aClass isObsolete ifTrue: [^self].
aClass removeFromChanges.
aClass removeFromSystemUnlogged
!
----- Method: ClassFactoryForTestCase>>deleteClasses (in category 'cleaning') -----
deleteClasses
self createdClasses do: [:class|
self delete: class]!
----- Method: ClassFactoryForTestCase>>deletePackage (in category 'cleaning') -----
deletePackage
| categoriesMatchString |
categoriesMatchString := self packageName, '-*'.
SystemOrganization removeCategoriesMatching: categoriesMatchString!
----- Method: ClassFactoryForTestCase>>initialize (in category 'cleaning') -----
initialize
super initialize.
self createdClasses: IdentitySet new!
----- Method: ClassFactoryForTestCase>>newClass (in category 'creating') -----
newClass
^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: ''!
----- Method: ClassFactoryForTestCase>>newClassInCategory: (in category 'creating') -----
newClassInCategory: category
^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: category!
----- Method: ClassFactoryForTestCase>>newName (in category 'creating') -----
newName
| postFix |
postFix := (self createdClasses size + 1) printString.
^#ClassForTestToBeDeleted, postFix!
----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames: (in category 'creating') -----
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString
^self
newSubclassOf: aClass
instanceVariableNames: ivNamesString
classVariableNames: classVarsString
category: self defaultCategoryPostfix!
----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames:category: (in category 'creating') -----
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category
| newClass |
newClass := aClass
subclass: self newName asSymbol
instanceVariableNames: ivNamesString
classVariableNames: classVarsString
poolDictionaries: ''
category: (self packageName, '-', category) asSymbol.
self createdClasses add: newClass.
^newClass!
----- Method: ClassFactoryForTestCase>>packageName (in category 'accessing') -----
packageName
^#CategoryForTestToBeDeleted!
Object subclass: #TestCase
instanceVariableNames: 'testSelector timeout'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
TestCase class
instanceVariableNames: 'history'!
!TestCase commentStamp: '<historical>' prior: 0!
A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs.
When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp.
When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.!
TestCase class
instanceVariableNames: 'history'!
TestCase subclass: #ClassFactoryForTestCaseTest
instanceVariableNames: 'factory'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
----- Method: ClassFactoryForTestCaseTest class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)!
----- Method: ClassFactoryForTestCaseTest>>setUp (in category 'setUp-tearDown') -----
setUp
super setUp.
factory := ClassFactoryForTestCase new!
----- Method: ClassFactoryForTestCaseTest>>tearDown (in category 'setUp-tearDown') -----
tearDown
super tearDown.
factory cleanUp!
----- Method: ClassFactoryForTestCaseTest>>testClassCreationInDifferentCategories (in category 'testing') -----
testClassCreationInDifferentCategories
| firstThreeClasses lastTwoClasses |
3 timesRepeat: [
factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One].
firstThreeClasses := factory createdClasses copy.
2 timesRepeat: [
factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two].
lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses.
self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]).
self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).!
----- Method: ClassFactoryForTestCaseTest>>testClassFastCreationInDifferentCategories (in category 'testing') -----
testClassFastCreationInDifferentCategories
| firstThreeClasses lastTwoClasses |
3 timesRepeat: [
factory newClassInCategory: #One].
firstThreeClasses := factory createdClasses copy.
2 timesRepeat: [
factory newClassInCategory: #Two].
lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses.
self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]).
self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).!
----- Method: ClassFactoryForTestCaseTest>>testDefaultCategoryCleanUp (in category 'testing') -----
testDefaultCategoryCleanUp
| createdClassNames allClasses |
3 timesRepeat: [
factory newClass].
createdClassNames := factory createdClassNames.
factory cleanUp.
self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]).
allClasses := SystemNavigation new allClasses.
self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]).
self deny: (SystemOrganization categories includes: factory defaultCategory).
self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames)
!
----- Method: ClassFactoryForTestCaseTest>>testMultipleClassCreation (in category 'testing') -----
testMultipleClassCreation
5 timesRepeat: [
factory newClass].
self assert: (SystemNavigation new allClasses includesAllOf: factory createdClasses).
self assert: factory createdClassNames asSet size = 5.
self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet!
----- Method: ClassFactoryForTestCaseTest>>testPackageCleanUp (in category 'testing') -----
testPackageCleanUp
| createdClassNames allClasses |
3 timesRepeat: [
factory newClassInCategory: #One].
2 timesRepeat: [
factory newClassInCategory: #Two].
createdClassNames := factory createdClassNames.
factory cleanUp.
self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]).
allClasses := SystemNavigation new allClasses.
self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]).
self assert: (SystemOrganization categoriesMatching: factory packageName, '*') isEmpty.
self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames)
!
----- Method: ClassFactoryForTestCaseTest>>testSingleClassCreation (in category 'testing') -----
testSingleClassCreation
|class elementsInCategoryForTest |
class := factory
newSubclassOf: Object
instanceVariableNames: 'a b c'
classVariableNames: 'X Y'.
self assert: (SystemNavigation new allClasses includes: class).
elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory.
self assert: elementsInCategoryForTest = {class name}.
self assert: class instVarNames = #(a b c).
self assert: class classPool keys asSet = #(X Y) asSet!
----- Method: ClassFactoryForTestCaseTest>>testSingleClassFastCreation (in category 'testing') -----
testSingleClassFastCreation
|class elementsInCategoryForTest |
class := factory newClass.
self assert: (SystemNavigation new allClasses includes: class).
elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory.
self assert: elementsInCategoryForTest = {class name}.
self assert: class instVarNames isEmpty.
self assert: class classPool isEmpty!
TestCase subclass: #ClassTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Extensions'!
!ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0!
This class is intended for unit tests of individual classes and their metaclasses.
It provides methods to determine the coverage of the unit tests.
Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored.
They should also implement to confirm that all methods have been tested.
#testCoverage
super testCoverage.
!
----- Method: ClassTestCase class>>isAbstract (in category 'Testing') -----
isAbstract
"Override to true if a TestCase subclass is Abstract and should not have
TestCase instances built from it"
^self name = #ClassTestCase
!
----- Method: ClassTestCase class>>mustTestCoverage (in category 'Testing') -----
mustTestCoverage
^ false!
----- Method: ClassTestCase>>categoriesForClass: (in category 'private') -----
categoriesForClass: aClass
^ aClass organization allMethodSelectors collect:
[:each | aClass organization categoryOfElement: each].
!
----- Method: ClassTestCase>>classToBeTested (in category 'coverage') -----
classToBeTested
self subclassResponsibility!
----- Method: ClassTestCase>>selectorsNotTested (in category 'coverage') -----
selectorsNotTested
^ self selectorsToBeTested difference: self selectorsTested.
!
----- Method: ClassTestCase>>selectorsTested (in category 'Coverage') -----
selectorsTested
| literals |
literals := Set new.
self class
selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test')
ifTrue: [ literals addAll: (m messages)] ].
^ literals asSortedArray!
----- Method: ClassTestCase>>selectorsToBeIgnored (in category 'coverage') -----
selectorsToBeIgnored
^ #(#DoIt #DoItIn:)!
----- Method: ClassTestCase>>selectorsToBeTested (in category 'coverage') -----
selectorsToBeTested
^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors])
difference: self selectorsToBeIgnored!
----- Method: ClassTestCase>>targetClass (in category 'private') -----
targetClass
|className|
className := self class name asText copyFrom: 0 to: self class name size - 4.
^ Smalltalk at: (className asString asSymbol).
!
----- Method: ClassTestCase>>testClassComment (in category 'tests') -----
testClassComment
self shouldnt: [self targetClass organization hasNoComment].!
----- Method: ClassTestCase>>testCoverage (in category 'tests') -----
testCoverage
| untested |
self class mustTestCoverage ifTrue:
[ untested := self selectorsNotTested.
self assert: untested isEmpty
description: untested size asString, ' selectors are not covered' ]!
----- Method: ClassTestCase>>testNew (in category 'tests') -----
testNew
"This should not throw an exception."
self targetClass new.!
----- Method: ClassTestCase>>testUnCategorizedMethods (in category 'tests') -----
testUnCategorizedMethods
| categories slips |
categories := self categoriesForClass: self targetClass.
slips := categories select: [:each | each = #'as yet unclassified'].
self should: [slips isEmpty]. !
TestCase subclass: #LongTestCase
instanceVariableNames: ''
classVariableNames: 'ShouldRun'
poolDictionaries: ''
category: 'SUnit-Extensions'!
!LongTestCase commentStamp: 'ul 12/15/2009 13:06' prior: 0!
A LongTestCase is a TestCase that usually takes a long time to run. Because of this users can decide if they want to execute these or not, by changing the "Run long test cases" preference.!
----- Method: LongTestCase class>>allTestSelectors (in category 'accessing') -----
allTestSelectors
self shouldRun ifTrue: [
^super testSelectors ].
^#().!
----- Method: LongTestCase class>>buildSuite (in category 'instance creation') -----
buildSuite
self shouldRun ifTrue: [ ^super buildSuite ].
^self suiteClass new!
----- Method: LongTestCase class>>doNotRunLongTestCases (in category 'accessing') -----
doNotRunLongTestCases
self shouldRun: false!
----- Method: LongTestCase class>>isAbstract (in category 'testing') -----
isAbstract
"Override to true if a TestCase subclass is Abstract and should not have
TestCase instances built from it"
^self name == #LongTestCase
!
----- Method: LongTestCase class>>runLongTestCases (in category 'accessing') -----
runLongTestCases
self shouldRun: true!
----- Method: LongTestCase class>>shouldRun (in category 'accessing') -----
shouldRun
<preference: 'Run long test cases'
category: 'SUnit'
description: 'If true, the tests defined in subclasses of LongTestCase will run, if they are selected in the Test Runner, otherwise not. As the name suggests, running these tests can take a long time.'
type: #Boolean>
^ShouldRun ifNil: [ true ]!
----- Method: LongTestCase class>>shouldRun: (in category 'accessing') -----
shouldRun: aBoolean
ShouldRun := aBoolean!
----- Method: LongTestCase>>defaultTimeout (in category 'as yet unclassified') -----
defaultTimeout
"Answer the default timeout to use for tests in this test case. The timeout is a value in seconds."
^super defaultTimeout * 10!
LongTestCase subclass: #LongTestCaseTestUnderTest
instanceVariableNames: ''
classVariableNames: 'RunStatus'
poolDictionaries: ''
category: 'SUnit-Extensions'!
----- Method: LongTestCaseTestUnderTest class>>hasRun (in category 'accessing') -----
hasRun
^ RunStatus!
----- Method: LongTestCaseTestUnderTest class>>markAsNotRun (in category 'accessing') -----
markAsNotRun
^ RunStatus := false!
----- Method: LongTestCaseTestUnderTest>>testWhenRunMarkTestedToTrue (in category 'testing') -----
testWhenRunMarkTestedToTrue
RunStatus := true.!
TestCase subclass: #LongTestCaseTest
instanceVariableNames: 'preferenceValue'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Extensions'!
----- Method: LongTestCaseTest>>setUp (in category 'as yet unclassified') -----
setUp
preferenceValue := LongTestCase shouldRun!
----- Method: LongTestCaseTest>>tearDown (in category 'as yet unclassified') -----
tearDown
LongTestCase shouldRun: preferenceValue!
----- Method: LongTestCaseTest>>testLongTestCaseDoNotRun (in category 'testing') -----
testLongTestCaseDoNotRun
"self debug: #testLongTestCaseDoNotRun"
"self run: #testLongTestCaseDoNotRun"
LongTestCase doNotRunLongTestCases.
LongTestCaseTestUnderTest markAsNotRun.
self deny: LongTestCaseTestUnderTest hasRun.
LongTestCaseTestUnderTest suite run.
self deny: LongTestCaseTestUnderTest hasRun.
!
----- Method: LongTestCaseTest>>testLongTestCaseRun (in category 'testing') -----
testLongTestCaseRun
"self debug: #testLongTestCaseRun"
"self run: #testLongTestCaseRun"
LongTestCase runLongTestCases.
LongTestCaseTestUnderTest markAsNotRun.
self deny: LongTestCaseTestUnderTest hasRun.
LongTestCaseTestUnderTest suite run.
self assert: LongTestCaseTestUnderTest hasRun.
LongTestCase doNotRunLongTestCases.
!
TestCase subclass: #ResumableTestFailureTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
----- Method: ResumableTestFailureTestCase class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#passed->((Set new) add: #testResumable; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)!
----- Method: ResumableTestFailureTestCase>>errorTest (in category 'not categorized') -----
errorTest
1 zork
!
----- Method: ResumableTestFailureTestCase>>failureTest (in category 'not categorized') -----
failureTest
self
assert: false description: 'You should see me' resumable: true;
assert: false description: 'You should see me too' resumable: true;
assert: false description: 'You should see me last' resumable: false;
assert: false description: 'You should not see me' resumable: true
!
----- Method: ResumableTestFailureTestCase>>okTest (in category 'not categorized') -----
okTest
self assert: true
!
----- Method: ResumableTestFailureTestCase>>regularTestFailureTest (in category 'not categorized') -----
regularTestFailureTest
self assert: false description: 'You should see me'
!
----- Method: ResumableTestFailureTestCase>>resumableTestFailureTest (in category 'not categorized') -----
resumableTestFailureTest
self
assert: false description: 'You should see me' resumable: true;
assert: false description: 'You should see me too' resumable: true;
assert: false description: 'You should see me last' resumable: false;
assert: false description: 'You should not see me' resumable: true
!
----- Method: ResumableTestFailureTestCase>>testResumable (in category 'not categorized') -----
testResumable
| result suite |
suite := TestSuite new.
suite addTest: (self class selector: #errorTest).
suite addTest: (self class selector: #regularTestFailureTest).
suite addTest: (self class selector: #resumableTestFailureTest).
suite addTest: (self class selector: #okTest).
result := suite run.
self assert: result failures size = 2;
assert: result errors size = 1
!
TestCase subclass: #SUnitExtensionsTest
instanceVariableNames: 'stream'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
----- Method: SUnitExtensionsTest class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#passed->((Set new) add: #testNoExceptionWithMatchingString; add: #testNoExceptionWithNoMatchingString; add: #testExceptionWithMatchingString; add: #testExceptionWithoutMatchingString; add: #testValidShouldNotTakeMoreThan; add: #testInvalidShouldNotTakeMoreThanMilliseconds; add: #testDifferentExceptionInShouldRaiseWithExceptionDo; add: #testShouldRaiseWithExceptionDo; add: #testShouldFix; add: #testAssertionFailedInRaiseWithExceptionDo; add: #testAutoDenyFalse; add: #testAutoDenyTrue; add: #testAutoAssertFalse; add: #testAutoAssertTrue; add: #testValidShouldNotTakeMoreThanMilliseconds; add: #testErrorInRaiseWithExceptionDo; add: #testNoExceptionInShouldRaiseWithExceptionDo; add: #testInvalidShouldNotTakeMoreThan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)!
----- Method: SUnitExtensionsTest>>assertionFailedInRaiseWithExceptionDoTest (in category 'real tests') -----
assertionFailedInRaiseWithExceptionDoTest
self
should: [ Error signal ]
raise: Error
withExceptionDo: [ :anException | self assert: false ]!
----- Method: SUnitExtensionsTest>>differentExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') -----
differentExceptionInShouldRaiseWithExceptionDoTest
[ self
should: [ Error signal ]
raise: Halt
withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ]
on: Error
do: [ :anException | anException return: nil ]!
----- Method: SUnitExtensionsTest>>errorInRaiseWithExceptionDoTest (in category 'real tests') -----
errorInRaiseWithExceptionDoTest
self
should: [ Error signal ]
raise: Error
withExceptionDo: [ :anException | Error signal: 'A forced error' ]!
----- Method: SUnitExtensionsTest>>failureLog (in category 'test support') -----
failureLog
^self stream!
----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThan (in category 'real tests') -----
invalidShouldNotTakeMoreThan
self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.!
----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThanMilliseconds (in category 'real tests') -----
invalidShouldNotTakeMoreThanMilliseconds
self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50!
----- Method: SUnitExtensionsTest>>isLogging (in category 'testing') -----
isLogging
^true!
----- Method: SUnitExtensionsTest>>noExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') -----
noExceptionInShouldRaiseWithExceptionDoTest
self
should: [ ]
raise: Error
withExceptionDo: [ :anException | Error signal: 'Should not get here' ]!
----- Method: SUnitExtensionsTest>>shouldFixTest (in category 'real tests') -----
shouldFixTest
self shouldFix: [ Error signal: 'any kind of error' ]
!
----- Method: SUnitExtensionsTest>>shouldRaiseWithExceptionDoTest (in category 'real tests') -----
shouldRaiseWithExceptionDoTest
self
should: [ Error signal: '1' ]
raise: Error
withExceptionDo: [ :anException | self assert: anException messageText = '1' ]!
----- Method: SUnitExtensionsTest>>shouldRaiseWithSignalDoTest (in category 'real tests') -----
shouldRaiseWithSignalDoTest
self
should: [ Error signal: '1' ]
raise: Error
withExceptionDo: [ :anException | self assert: anException messageText = '1' ]!
----- Method: SUnitExtensionsTest>>stream (in category 'accessing') -----
stream
^stream ifNil: [stream := WriteStream on: String new]!
----- Method: SUnitExtensionsTest>>testAssertionFailedInRaiseWithExceptionDo (in category 'test') -----
testAssertionFailedInRaiseWithExceptionDo
| testCase testResult |
testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest.
testResult := testCase run.
self assert: (testResult failures includes: testCase).
self assert: testResult failures size=1.
self assert: testResult passed isEmpty.
self assert: testResult errors isEmpty.
!
----- Method: SUnitExtensionsTest>>testAutoAssertFalse (in category 'test') -----
testAutoAssertFalse
| booleanCondition |
self assert: self isLogging.
self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: TestResult failure.
booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self assert: 1 = 2'.
self assert: booleanCondition!
----- Method: SUnitExtensionsTest>>testAutoAssertTrue (in category 'test') -----
testAutoAssertTrue
self assert: 1 = 1.
self assert: true!
----- Method: SUnitExtensionsTest>>testAutoDenyFalse (in category 'test') -----
testAutoDenyFalse
| booleanCondition |
self assert: self isLogging.
self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: TestResult failure.
booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self deny: 1 = 1'.
self assert: booleanCondition!
----- Method: SUnitExtensionsTest>>testAutoDenyTrue (in category 'test') -----
testAutoDenyTrue
self deny: 1 = 2.
self deny: false!
----- Method: SUnitExtensionsTest>>testDifferentExceptionInShouldRaiseWithExceptionDo (in category 'test') -----
testDifferentExceptionInShouldRaiseWithExceptionDo
| testCase testResult |
testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest.
testResult := testCase run.
self assert: (testResult passed includes: testCase).
self assert: testResult errors isEmpty.
self assert: testResult failures isEmpty.
self assert: testResult passed size=1!
----- Method: SUnitExtensionsTest>>testErrorInRaiseWithExceptionDo (in category 'test') -----
testErrorInRaiseWithExceptionDo
| testCase testResult |
testCase := self class selector: #errorInRaiseWithExceptionDoTest.
testResult := testCase run.
self assert: (testResult errors includes: testCase).
self assert: testResult errors size=1.
self assert: testResult failures isEmpty.
self assert: testResult passed isEmpty.
!
----- Method: SUnitExtensionsTest>>testExceptionWithMatchingString (in category 'as yet unclassified') -----
testExceptionWithMatchingString
self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'!
----- Method: SUnitExtensionsTest>>testExceptionWithoutMatchingString (in category 'as yet unclassified') -----
testExceptionWithoutMatchingString
self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'!
----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThan (in category 'test') -----
testInvalidShouldNotTakeMoreThan
| testCase testResult |
testCase := self class selector: #invalidShouldNotTakeMoreThan.
testResult := testCase run.
self assert: testResult passed isEmpty.
self assert: testResult failures size = 1.
self assert: (testResult failures includes: testCase).
self assert: testResult errors isEmpty
!
----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThanMilliseconds (in category 'test') -----
testInvalidShouldNotTakeMoreThanMilliseconds
| testCase testResult |
testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds.
testResult := testCase run.
self assert: testResult passed isEmpty.
self assert: testResult failures size = 1.
self assert: (testResult failures includes: testCase).
self assert: testResult errors isEmpty
!
----- Method: SUnitExtensionsTest>>testNoExceptionInShouldRaiseWithExceptionDo (in category 'test') -----
testNoExceptionInShouldRaiseWithExceptionDo
| testCase testResult |
testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest.
testResult := testCase run.
self assert: (testResult failures includes: testCase).
self assert: testResult failures size=1.
self assert: testResult passed isEmpty.
self assert: testResult errors isEmpty.
!
----- Method: SUnitExtensionsTest>>testNoExceptionWithMatchingString (in category 'as yet unclassified') -----
testNoExceptionWithMatchingString
self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'!
----- Method: SUnitExtensionsTest>>testNoExceptionWithNoMatchingString (in category 'as yet unclassified') -----
testNoExceptionWithNoMatchingString
self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'!
----- Method: SUnitExtensionsTest>>testShouldFix (in category 'test') -----
testShouldFix
| testCase testResult |
testCase := self class selector: #shouldFixTest.
testResult := testCase run.
self assert: (testResult passed includes: testCase).
self assert: testResult passed size=1.
self assert: testResult failures isEmpty.
self assert: testResult errors isEmpty.
!
----- Method: SUnitExtensionsTest>>testShouldRaiseWithExceptionDo (in category 'test') -----
testShouldRaiseWithExceptionDo
| testCase testResult |
testCase := self class selector: #shouldRaiseWithExceptionDoTest.
testResult := testCase run.
self assert: (testResult passed includes: testCase).
self assert: testResult passed size=1.
self assert: testResult failures isEmpty.
self assert: testResult errors isEmpty.
!
----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThan (in category 'test') -----
testValidShouldNotTakeMoreThan
| testCase testResult |
testCase := self class selector: #validShouldNotTakeMoreThan.
testResult := testCase run.
self assert: (testResult passed includes: testCase).
self assert: testResult passed size = 1.
self assert: testResult failures isEmpty.
self assert: testResult errors isEmpty
!
----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThanMilliseconds (in category 'test') -----
testValidShouldNotTakeMoreThanMilliseconds
| testCase testResult |
testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds.
testResult := testCase run.
self assert: (testResult passed includes: testCase).
self assert: testResult passed size = 1.
self assert: testResult failures isEmpty.
self assert: testResult errors isEmpty
!
----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThan (in category 'real tests') -----
validShouldNotTakeMoreThan
self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 200 milliSeconds.!
----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThanMilliseconds (in category 'real tests') -----
validShouldNotTakeMoreThanMilliseconds
self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200!
TestCase subclass: #SUnitTest
instanceVariableNames: 'hasRun hasSetup hasRanOnce'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
!SUnitTest commentStamp: '<historical>' prior: 0!
This is both an example of writing tests and a self test for the SUnit. The tests
here are pretty strange, since you want to make sure things blow up. You should
not generally have to write tests this complicated in structure, although they
will be far more complicated in terms of your own objects- more assertions, more
complicated setup. Kent says: "Never forget, however, that if the tests are hard
to write, something is probably wrong with the design".!
----- Method: SUnitTest class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#passed->((Set new) add: #testWithExceptionDo; add: #testRan; add: #testAssert; add: #testRanOnlyOnce; add: #testDialectLocalizedException; add: #testFail; add: #testDefects; add: #testIsNotRerunOnDebug; add: #testResult; add: #testRunning; add: #testError; add: #testException; add: #testShould; add: #testSuite; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)!
----- Method: SUnitTest>>assertForTestResult:runCount:passed:failed:errors: (in category 'private') -----
assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount
self
assert: aResult runCount = aRunCount;
assert: aResult passedCount = aPassedCount;
assert: aResult failureCount = aFailureCount;
assert: aResult errorCount = anErrorCount
!
----- Method: SUnitTest>>error (in category 'private') -----
error
3 zork
!
----- Method: SUnitTest>>errorShouldntRaise (in category 'testing') -----
errorShouldntRaise
self
shouldnt: [self someMessageThatIsntUnderstood]
raise: Notification new
!
----- Method: SUnitTest>>fail (in category 'private') -----
fail
self assert: false
!
----- Method: SUnitTest>>hasRun (in category 'accessing') -----
hasRun
^hasRun
!
----- Method: SUnitTest>>hasSetup (in category 'accessing') -----
hasSetup
^hasSetup
!
----- Method: SUnitTest>>noop (in category 'private') -----
noop
!
----- Method: SUnitTest>>setRun (in category 'private') -----
setRun
hasRun := true
!
----- Method: SUnitTest>>setUp (in category 'running') -----
setUp
hasSetup := true
!
----- Method: SUnitTest>>testAssert (in category 'testing') -----
testAssert
self assert: true.
self deny: false
!
----- Method: SUnitTest>>testAssertIdentical (in category 'testing') -----
testAssertIdentical
| a b |
a := 'foo'.
b := 'bar'.
self should: [self assert: a identical: b] raise: TestFailure.
[self assert: a identical: b] on: TestFailure do: [:e | |error|
error := e messageText.
self assert: (error includesSubString: a) description: 'Error message doesn''t include the expected value'.
self assert: (error includesSubString: b) description: 'Error message doesn''t include the expected value'].!
----- Method: SUnitTest>>testAssertIdenticalDescription (in category 'testing') -----
testAssertIdenticalDescription
| a b |
a := 'foo'.
b := a copy.
self should: [self assert: a identical: b description: 'A desciption'] raise: TestFailure.
[self assert: a identical: b description: 'A desciption'] on: TestFailure do: [:e | |error|
error := e messageText.
self assert: (error includesSubString: 'A desciption') description: 'Error message doesn''t give you the description'].!
----- Method: SUnitTest>>testAssertIdenticalWithEqualObjects (in category 'testing') -----
testAssertIdenticalWithEqualObjects
| a b |
a := 'foo'.
b := a copy.
self should: [self assert: a identical: b] raise: TestFailure.
[self assert: a identical: b] on: TestFailure do: [:e | |error|
error := e messageText.
self assert: (error includesSubString: 'not identical') description: 'Error message doesn''t say the two things aren''t identical'].!
----- Method: SUnitTest>>testDefects (in category 'testing') -----
testDefects
| result suite error failure |
suite := TestSuite new.
suite addTest: (error := self class selector: #error).
suite addTest: (failure := self class selector: #fail).
result := suite run.
self assert: result defects asArray = (Array with: error with: failure).
self
assertForTestResult: result
runCount: 2
passed: 0
failed: 1
errors: 1
!
----- Method: SUnitTest>>testDialectLocalizedException (in category 'testing') -----
testDialectLocalizedException
self
should: [TestResult signalFailureWith: 'Foo']
raise: TestResult failure.
self
should: [TestResult signalErrorWith: 'Foo']
raise: TestResult error.
!
----- Method: SUnitTest>>testError (in category 'testing') -----
testError
| case result |
case := self class selector: #error.
result := case run.
self
assertForTestResult: result
runCount: 1
passed: 0
failed: 0
errors: 1.
case := self class selector: #errorShouldntRaise.
result := case run.
self
assertForTestResult: result
runCount: 1
passed: 0
failed: 0
errors: 1
!
----- Method: SUnitTest>>testException (in category 'testing') -----
testException
self
should: [self error: 'foo']
raise: TestResult error
!
----- Method: SUnitTest>>testFail (in category 'testing') -----
testFail
| case result |
case := self class selector: #fail.
result := case run.
self
assertForTestResult: result
runCount: 1
passed: 0
failed: 1
errors: 0
!
----- Method: SUnitTest>>testRan (in category 'testing') -----
testRan
| case |
case := self class selector: #setRun.
case run.
self assert: case hasSetup.
self assert: case hasRun
!
----- Method: SUnitTest>>testRanOnlyOnce (in category 'testing') -----
testRanOnlyOnce
self assert: hasRanOnce ~= true.
hasRanOnce := true
!
----- Method: SUnitTest>>testResult (in category 'testing') -----
testResult
| case result |
case := self class selector: #noop.
result := case run.
self
assertForTestResult: result
runCount: 1
passed: 1
failed: 0
errors: 0
!
----- Method: SUnitTest>>testRunning (in category 'testing') -----
testRunning
(Delay forSeconds: 2) wait
!
----- Method: SUnitTest>>testSelectorWithArg: (in category 'testing') -----
testSelectorWithArg: anObject
"should not result in error"!
----- Method: SUnitTest>>testShould (in category 'testing') -----
testShould
self
should: [true];
shouldnt: [false]
!
----- Method: SUnitTest>>testSuite (in category 'testing') -----
testSuite
| suite result |
suite := TestSuite new.
suite
addTest: (self class selector: #noop);
addTest: (self class selector: #fail);
addTest: (self class selector: #error).
result := suite run.
self
assertForTestResult: result
runCount: 3
passed: 1
failed: 1
errors: 1
!
----- Method: SUnitTest>>testTestTimeout (in category 'testing') -----
testTestTimeout
self should:[(Delay forSeconds: 6) wait] raise: TestFailure.
!
----- Method: SUnitTest>>testTestTimeoutLoop (in category 'testing') -----
testTestTimeoutLoop
<timeout: 1>
self should:[[] repeat] raise: TestFailure.
!
----- Method: SUnitTest>>testTestTimeoutTag (in category 'testing') -----
testTestTimeoutTag
<timeout: 1>
self should:[(Delay forSeconds: 3) wait] raise: TestFailure.
!
----- Method: SUnitTest>>testWithExceptionDo (in category 'testing') -----
testWithExceptionDo
self
should: [self error: 'foo']
raise: TestResult error
withExceptionDo: [:exception |
self assert: (exception description includesSubString: 'foo')
]
!
TestCase subclass: #SimpleTestResourceTestCase
instanceVariableNames: 'resource'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
----- Method: SimpleTestResourceTestCase class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#passed->((Set new) add: #testResourceInitRelease; add: #testResourcesCollection; add: #testRan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)!
----- Method: SimpleTestResourceTestCase class>>resources (in category 'not categorized') -----
resources
^Set new add: SimpleTestResource; yourself
!
----- Method: SimpleTestResourceTestCase>>dummy (in category 'not categorized') -----
dummy
self assert: true
!
----- Method: SimpleTestResourceTestCase>>error (in category 'not categorized') -----
error
'foo' odd
!
----- Method: SimpleTestResourceTestCase>>fail (in category 'not categorized') -----
fail
self assert: false
!
----- Method: SimpleTestResourceTestCase>>setRun (in category 'not categorized') -----
setRun
resource setRun
!
----- Method: SimpleTestResourceTestCase>>setUp (in category 'not categorized') -----
setUp
resource := SimpleTestResource current
!
----- Method: SimpleTestResourceTestCase>>testRan (in category 'not categorized') -----
testRan
| case |
case := self class selector: #setRun.
case run.
self assert: resource hasSetup.
self assert: resource hasRun
!
----- Method: SimpleTestResourceTestCase>>testResourceInitRelease (in category 'not categorized') -----
testResourceInitRelease
| result suite error failure |
suite := TestSuite new.
suite addTest: (error := self class selector: #error).
suite addTest: (failure := self class selector: #fail).
suite addTest: (self class selector: #dummy).
result := suite run.
self assert: resource hasSetup
!
----- Method: SimpleTestResourceTestCase>>testResourcesCollection (in category 'not categorized') -----
testResourcesCollection
| collection |
collection := self resources.
self assert: collection size = 1
!
----- Method: TestCase class>>addTestsFor:toSuite: (in category 'building suites') -----
addTestsFor: classNameString toSuite: suite
| cls |
cls := Smalltalk at: classNameString ifAbsent: [ ^suite ].
^cls isAbstract
ifTrue: [
cls allSubclasses do: [ :each |
each isAbstract ifFalse: [
each addToSuiteFromSelectors: suite ] ].
suite]
ifFalse: [ cls addToSuiteFromSelectors: suite ]
!
----- Method: TestCase class>>addToSuite:fromMethods: (in category 'building suites') -----
addToSuite: suite fromMethods: testMethods
testMethods do: [ :selector |
suite addTest: (self selector: selector) ].
^suite!
----- Method: TestCase class>>addToSuiteFromSelectors: (in category 'building suites') -----
addToSuiteFromSelectors: suite
^self addToSuite: suite fromMethods: (self shouldInheritSelectors
ifTrue: [ self allTestSelectors ]
ifFalse: [self testSelectors ])!
----- Method: TestCase class>>allTestSelectors (in category 'accessing') -----
allTestSelectors
^(self allSelectors asArray select: [ :each |
(each beginsWith: 'test') and: [ each numArgs isZero ] ]) sort
!
----- Method: TestCase class>>buildSuite (in category 'building suites') -----
buildSuite
| suite |
suite := self suiteClass new.
^ self isAbstract
ifTrue: [
suite name: self name asString.
self allSubclasses
do: [:each | each isAbstract
ifFalse: [each addToSuiteFromSelectors: suite]].
suite]
ifFalse: [self addToSuiteFromSelectors: suite]!
----- Method: TestCase class>>buildSuiteFromAllSelectors (in category 'building suites') -----
buildSuiteFromAllSelectors
^self buildSuiteFromMethods: self allTestSelectors
!
----- Method: TestCase class>>buildSuiteFromLocalSelectors (in category 'building suites') -----
buildSuiteFromLocalSelectors
^self buildSuiteFromMethods: self testSelectors
!
----- Method: TestCase class>>buildSuiteFromMethods: (in category 'building suites') -----
buildSuiteFromMethods: testMethods
| suite |
suite := (self suiteClass new)
name: self name asString;
yourself.
^self addToSuite: suite fromMethods: testMethods!
----- Method: TestCase class>>buildSuiteFromSelectors (in category 'building suites') -----
buildSuiteFromSelectors
^self shouldInheritSelectors
ifTrue: [self buildSuiteFromAllSelectors]
ifFalse: [self buildSuiteFromLocalSelectors]
!
----- Method: TestCase class>>coverage (in category 'coverage') -----
coverage
"returns the coverage determined by a simple static analysis of test coverage
made by the receiver on a class that is identified by the name of the receiver.
We assume that SetTest test Set."
| cls className |
(self name endsWith: 'Test') ifFalse: [self error: 'Please, use #coverageForClass: instead'].
className := self name copyFrom: 1 to: (self name size - 'Test' size).
cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #coverageForClass: instead'].
"May happen with Transcript"
cls isBehavior ifFalse: [cls := cls class].
^ self coverageForClass: cls!
----- Method: TestCase class>>coverageAsString (in category 'coverage') -----
coverageAsString
| cov className |
cov := self coverage first asInteger.
"coverage already checks that the name is ends with 'Test' and if the class tested exists"
className := self name copyFrom: 1 to: (self name size - 'Test' size).
^ self name asString, ' covers ', cov asString, '% of ', className.!
----- Method: TestCase class>>coverageForClass: (in category 'coverage') -----
coverageForClass: cls
"returns the test coverage of all the methods included inherited ones"
^ self coverageForClass: cls until: ProtoObject!
----- Method: TestCase class>>coverageForClass:until: (in category 'coverage') -----
coverageForClass: cls until: aRootClass
"returns the test coverage of all the methods included inherited ones but stopping at aRootClass included"
| definedMethods testedMethods untestedMethods |
definedMethods := cls allSelectorsAboveUntil: aRootClass.
definedMethods size = 0
ifTrue: [^ {0. Set new}].
testedMethods :=
self methodDictionary inject: Set new into:
[:sums :cm | sums union: cm messages].
testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not].
untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not].
^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods}
!
----- Method: TestCase class>>coveragePercentage (in category 'coverage') -----
coveragePercentage
^ self coverage first!
----- Method: TestCase class>>debug: (in category 'instance creation') -----
debug: aSymbol
^(self selector: aSymbol) debug
!
----- Method: TestCase class>>generateLastStoredRunMethod (in category 'history') -----
generateLastStoredRunMethod
self shouldGenerateLastStoredRunMethod ifTrue: [
self class
compile: (self lastRunMethodNamed: #lastStoredRun)
classified: 'history' ]!
----- Method: TestCase class>>hasMethodBeenRun: (in category 'testing') -----
hasMethodBeenRun: aSelector
^ ((self lastRun at: #errors),
(self lastRun at: #failures),
(self lastRun at: #passed))
includes: aSelector!
----- Method: TestCase class>>history (in category 'history') -----
history
^ history ifNil: [ history := self newTestDictionary ]!
----- Method: TestCase class>>history: (in category 'history') -----
history: aDictionary
history := aDictionary!
----- Method: TestCase class>>initialize (in category 'initialize - event') -----
initialize
super initialize.
SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #methodChanged:.!
----- Method: TestCase class>>isAbstract (in category 'testing') -----
isAbstract
"Override to true if a TestCase subclass is Abstract and should not have
TestCase instances built from it"
^self name = #TestCase
!
----- Method: TestCase class>>lastRun (in category 'history') -----
lastRun
^ TestResult historyFor: self!
----- Method: TestCase class>>lastRunMethodNamed: (in category 'history') -----
lastRunMethodNamed: aSelector
^ String streamContents: [:str |
str nextPutAll: aSelector asString ;cr.
str tab; nextPutAll: '^ ', (self lastRun) storeString]
!
----- Method: TestCase class>>lastStoredRun (in category 'history') -----
lastStoredRun
^ ((Dictionary new) add: (#failures->#()); add: (#passed->#()); add: (#errors->#()); yourself)!
----- Method: TestCase class>>localCoverage (in category 'coverage') -----
localCoverage
"returns the coverage determined by a simple static analysis of test coverage
made by the receiver on a class that is identified by the name of the receiver.
We assume that SetTest test Set. The computation of the coverage takes only into
account the methods defined locally in the tested class. See coverage for a more global
coverage"
| cls className |
(self name endsWith: 'Test') ifFalse: [self error: 'Please, use #localCoverageForClass: instead'].
className := self name copyFrom: 1 to: (self name size - 'Test' size).
cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #localCoverageForClass: instead'].
cls isBehavior ifFalse: [cls := cls class].
^ self localCoverageForClass: cls!
----- Method: TestCase class>>localCoverageAsString (in category 'coverage') -----
localCoverageAsString
| cov className |
cov := self localCoverage first asInteger.
"coverage already checks that the name is ends with 'Test' and if the class tested exists"
className := self name copyFrom: 1 to: (self name size - 'Test' size).
^ self name asString, ' covers ', cov asString, '% of ', className.!
----- Method: TestCase class>>localCoverageForClass: (in category 'coverage') -----
localCoverageForClass: cls
| definedMethods testedMethods untestedMethods |
definedMethods := cls selectors asSet.
"It happens for IdentityBag / IdentityBagTest"
definedMethods size = 0
ifTrue: [^ {0. Set new}].
testedMethods :=
self methodDictionary inject: Set new into:
[:sums :cm | sums union: cm messages].
"testedMethods contains all the methods send in test methods, which probably contains methods that have nothign to do with collection"
testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not].
untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not].
^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods}
!
----- Method: TestCase class>>localCoveragePercentage (in category 'coverage') -----
localCoveragePercentage
^ self localCoverage first!
----- Method: TestCase class>>methodChanged: (in category 'initialize - event') -----
methodChanged: anEvent
"Remove the changed method from the known test results."
| cls sel |
anEvent item isCompiledMethod ifFalse: [ ^ self ].
cls := anEvent item methodClass.
(cls inheritsFrom: TestCase)
ifFalse: [^ self].
sel := anEvent item selector.
(sel beginsWith: 'test')
ifFalse: [^ self].
TestResult removeFromTestHistory: sel in: cls.
!
----- Method: TestCase class>>methodFailed: (in category 'testing') -----
methodFailed: aSelector
^ (self lastRun at: #failures) includes: aSelector!
----- Method: TestCase class>>methodPassed: (in category 'testing') -----
methodPassed: aSelector
^ (self lastRun at: #passed) includes: aSelector!
----- Method: TestCase class>>methodProgressed: (in category 'testing') -----
methodProgressed: aSelector
^ ((self storedMethodRaisedError: aSelector) or: [self storedMethodFailed: aSelector])
and: [self methodPassed: aSelector]
!
----- Method: TestCase class>>methodRaisedError: (in category 'testing') -----
methodRaisedError: aSelector
^ (self lastRun at: #errors) includes: aSelector!
----- Method: TestCase class>>methodRegressed: (in category 'testing') -----
methodRegressed: aSelector
^ (self storedMethodPassed: aSelector) and: [(self methodFailed: aSelector) or: [self methodRaisedError: aSelector]]!
----- Method: TestCase class>>newTestDictionary (in category 'history') -----
newTestDictionary
^ Dictionary new at: #timeStamp put: TimeStamp now;
at: #passed put: Set new;
at: #failures put: Set new;
at: #errors put: Set new;
yourself
!
----- Method: TestCase class>>resetHistory (in category 'history') -----
resetHistory
history := nil!
----- Method: TestCase class>>resources (in category 'accessing') -----
resources
^#()
!
----- Method: TestCase class>>run: (in category 'instance creation') -----
run: aSymbol
^(self selector: aSymbol) run
!
----- Method: TestCase class>>selector: (in category 'instance creation') -----
selector: aSymbol
^self new setTestSelector: aSymbol
!
----- Method: TestCase class>>shouldGenerateLastStoredRunMethod (in category 'history') -----
shouldGenerateLastStoredRunMethod
| sameRun |
(self class methodDictionary includesKey: #lastStoredRun)
ifFalse: [^ true].
sameRun := #(#passed #failures #errors) inject: true into:
[ :ok :set | ok and: [(self lastRun at: set) = (self lastStoredRun at: set) ]].
^ sameRun not
!
----- Method: TestCase class>>shouldInheritSelectors (in category 'testing') -----
shouldInheritSelectors
"I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass."
^self superclass isAbstract
or: [self testSelectors isEmpty]
"$QA Ignore:Sends system method(superclass)$"
!
----- Method: TestCase class>>storedMethodFailed: (in category 'testing') -----
storedMethodFailed: aSelector
^ (self lastStoredRun at: #failures) includes: aSelector!
----- Method: TestCase class>>storedMethodPassed: (in category 'testing') -----
storedMethodPassed: aSelector
^ (self lastStoredRun at: #passed) includes: aSelector!
----- Method: TestCase class>>storedMethodRaisedError: (in category 'testing') -----
storedMethodRaisedError: aSelector
^ (self lastStoredRun at: #errors) includes: aSelector!
----- Method: TestCase class>>suite (in category 'instance creation') -----
suite
^self buildSuite
!
----- Method: TestCase class>>suiteClass (in category 'building suites') -----
suiteClass
^TestSuite
!
----- Method: TestCase class>>sunitVersion (in category 'accessing') -----
sunitVersion
^'3.1'
!
----- Method: TestCase class>>testSelectors (in category 'Accessing') -----
testSelectors
^(self selectors asArray select: [ :each |
(each beginsWith: 'test') and: [ each numArgs isZero ] ]) sort!
----- Method: TestCase>>addDependentToHierachy: (in category 'dependencies') -----
addDependentToHierachy: anObject
"an empty method. for Composite compability with TestSuite"
!
----- Method: TestCase>>assert: (in category 'accessing') -----
assert: aBooleanOrBlock
aBooleanOrBlock value ifFalse: [self signalFailure: 'Assertion failed']
!
----- Method: TestCase>>assert:description: (in category 'accessing') -----
assert: aBooleanOrBlock description: aStringOrBlock
aBooleanOrBlock value ifFalse: [
| description |
description := aStringOrBlock value.
self logFailure: description.
TestResult failure signal: description ]
!
----- Method: TestCase>>assert:description:resumable: (in category 'accessing') -----
assert: aBooleanOrBlock description: aString resumable: resumableBoolean
| exception |
aBooleanOrBlock value
ifFalse:
[self logFailure: aString.
exception := resumableBoolean
ifTrue: [TestResult resumableFailure]
ifFalse: [TestResult failure].
exception signal: aString]
!
----- Method: TestCase>>assert:equals: (in category 'accessing') -----
assert: expected equals: actual
^self
assert: expected = actual
description: [ self comparingStringBetween: expected and: actual ]
!
----- Method: TestCase>>assert:equals:description: (in category 'accessing') -----
assert: expected equals: actual description: aString
^self
assert: expected = actual
description: [ aString , ': ', (self comparingStringBetween: expected and: actual) ]!
----- Method: TestCase>>assert:identical: (in category 'accessing') -----
assert: expected identical: actual
^self
assert: expected == actual
description: [ self comparingStringBetweenIdentical: expected and: actual ]
!
----- Method: TestCase>>assert:identical:description: (in category 'accessing') -----
assert: expected identical: actual description: aString
^self
assert: expected == actual
description: [ aString , ': ', (self comparingStringBetweenIdentical: expected and: actual) ]!
----- Method: TestCase>>comparingStringBetween:and: (in category 'private') -----
comparingStringBetween: expected and: actual
^ String streamContents: [:stream |
stream
nextPutAll: 'Expected ';
nextPutAll: (expected printStringLimitedTo: 10);
nextPutAll: ' but was ';
nextPutAll: (actual printStringLimitedTo: 10);
nextPutAll: '.'
]!
----- Method: TestCase>>comparingStringBetweenIdentical:and: (in category 'private') -----
comparingStringBetweenIdentical: expected and: actual
^ 'Expected {1} and actual {2} are not identical.' format: {
expected printStringLimitedTo: 10.
actual printStringLimitedTo: 10.
}!
----- Method: TestCase>>debug (in category 'running') -----
debug
self resources do:
[ : res | res isAvailable ifFalse: [ ^ res signalInitializationError ] ].
[ self runCase ] ensure:
[ self resources do:
[ : each | each reset ] ]!
----- Method: TestCase>>debugAsFailure (in category 'running') -----
debugAsFailure
| semaphore |
semaphore := Semaphore new.
self resources do: [:res |
res isAvailable ifFalse: [^res signalInitializationError]].
[semaphore wait. self resources do: [:each | each reset]] fork.
(self class selector: testSelector) runCaseAsFailure: semaphore.!
----- Method: TestCase>>defaultTimeout (in category 'accessing') -----
defaultTimeout
"Answer the default timeout to use for tests in this test case.
The timeout is a value in seconds."
^5 "seconds"!
----- Method: TestCase>>deny: (in category 'accessing') -----
deny: aBooleanOrBlock
self assert: aBooleanOrBlock value not
!
----- Method: TestCase>>deny:description: (in category 'accessing') -----
deny: aBooleanOrBlock description: aString
self assert: aBooleanOrBlock value not description: aString
!
----- Method: TestCase>>deny:description:resumable: (in category 'accessing') -----
deny: aBooleanOrBlock description: aString resumable: resumableBoolean
self
assert: aBooleanOrBlock value not
description: aString
resumable: resumableBoolean
!
----- Method: TestCase>>executeShould:inScopeOf: (in category 'private') -----
executeShould: aBlock inScopeOf: anExceptionalEvent
^[aBlock value.
false] on: anExceptionalEvent
do: [:ex | ex return: true]
!
----- Method: TestCase>>executeShould:inScopeOf:withDescriptionContaining: (in category 'private') -----
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString
^[aBlock value.
false] on: anExceptionalEvent
do: [:ex | ex return: (ex description includesSubString: aString) ]
!
----- Method: TestCase>>executeShould:inScopeOf:withDescriptionNotContaining: (in category 'private') -----
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString
^[aBlock value.
false] on: anExceptionalEvent
do: [:ex | ex return: (ex description includesSubString: aString) not ]
!
----- Method: TestCase>>executeShould:inScopeOf:withExceptionDo: (in category 'extensions') -----
executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock
^[aBlock value.
false]
on: anException
do: [:exception |
anotherBlock value: exception.
exception return: true]!
----- Method: TestCase>>expectedFailures (in category 'testing') -----
expectedFailures
^ Array new!
----- Method: TestCase>>fail (in category 'extensions') -----
fail
^self assert: false!
----- Method: TestCase>>fail: (in category 'extensions') -----
fail: aString
^self assert: false description: aString.!
----- Method: TestCase>>failureLog (in category 'running') -----
failureLog
^Transcript
!
----- Method: TestCase>>isLogging (in category 'running') -----
isLogging
"By default, we're not logging failures. If you override this in
a subclass, make sure that you override #failureLog"
^false
!
----- Method: TestCase>>logFailure: (in category 'running') -----
logFailure: aString
self isLogging ifTrue: [
self failureLog
cr;
nextPutAll: aString;
flush]
!
----- Method: TestCase>>openDebuggerOnFailingTestMethod (in category 'running') -----
openDebuggerOnFailingTestMethod
"SUnit has halted one step in front of the failing test method. Step over the 'self halt' and
send into 'self perform: testSelector' to see the failure from the beginning"
self
halt;
performTest!
----- Method: TestCase>>performTest (in category 'private') -----
performTest
self perform: testSelector asSymbol
!
----- Method: TestCase>>printOn: (in category 'printing') -----
printOn: aStream
testSelector
ifNil: [super printOn: aStream]
ifNotNil:
[aStream
nextPutAll: self class printString;
nextPutAll: '>>#';
nextPutAll: testSelector] !
----- Method: TestCase>>removeDependentFromHierachy: (in category 'dependencies') -----
removeDependentFromHierachy: anObject
"an empty method. for Composite compability with TestSuite"
!
----- Method: TestCase>>resources (in category 'accessing') -----
resources
| allResources resourceQueue |
allResources := Set new.
resourceQueue := OrderedCollection new.
resourceQueue addAll: self class resources.
[resourceQueue isEmpty] whileFalse: [
| next |
next := resourceQueue removeFirst.
allResources add: next.
resourceQueue addAll: next resources].
^allResources
!
----- Method: TestCase>>run (in category 'running') -----
run
| result |
result := TestResult new.
self run: result.
^result
!
----- Method: TestCase>>run: (in category 'running') -----
run: aResult
aResult runCase: self.
!
----- Method: TestCase>>runCase (in category 'running') -----
runCase
"Run this TestCase. Time out if the test takes too long."
[self timeout: [self setUp]
after: self timeoutForSetUp.
self timeout: [self performTest]
after: self timeoutForTest]
ensure: [self tearDown]!
----- Method: TestCase>>runCaseAsFailure: (in category 'running') -----
runCaseAsFailure: aSemaphore
[self setUp.
self openDebuggerOnFailingTestMethod] ensure: [
self tearDown.
aSemaphore signal]!
----- Method: TestCase>>selector (in category 'accessing') -----
selector
^testSelector
!
----- Method: TestCase>>setTestSelector: (in category 'private') -----
setTestSelector: aSymbol
testSelector := aSymbol
!
----- Method: TestCase>>setUp (in category 'running') -----
setUp!
----- Method: TestCase>>should: (in category 'accessing') -----
should: aBlock
self assert: aBlock value
!
----- Method: TestCase>>should:description: (in category 'accessing') -----
should: aBlock description: aString
self assert: aBlock value description: aString
!
----- Method: TestCase>>should:notTakeMoreThan: (in category 'extensions') -----
should: aBlock notTakeMoreThan: aDuration
"Evaluate aBlock in a forked process and if it takes more than anInteger milliseconds
to run we terminate the process and report a test failure. It'' important to
use the active process for the test failure so that the failure reporting works correctly
in the context of the exception handlers."
| evaluated evaluationProcess result delay testProcess |
evaluated := false.
delay := Delay forDuration: aDuration.
testProcess := Processor activeProcess.
"Create a new process to evaluate aBlock"
evaluationProcess := [
result := aBlock value.
evaluated := true.
delay unschedule.
testProcess resume ] forkNamed: 'Process to evaluate should: notTakeMoreThanMilliseconds:'.
"Wait the milliseconds they asked me to"
delay wait.
"After this point either aBlock was evaluated or not..."
evaluated ifFalse: [
evaluationProcess terminate.
self assert: false description: ('Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration)].
^result!
----- Method: TestCase>>should:notTakeMoreThanMilliseconds: (in category 'extensions') -----
should: aBlock notTakeMoreThanMilliseconds: anInteger
"For compatibility with other Smalltalks"
self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).!
----- Method: TestCase>>should:raise: (in category 'accessing') -----
should: aBlock raise: anExceptionalEvent
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
!
----- Method: TestCase>>should:raise:description: (in category 'accessing') -----
should: aBlock raise: anExceptionalEvent description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
description: aString
!
----- Method: TestCase>>should:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') -----
should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString)
description: aString
!
----- Method: TestCase>>should:raise:whoseDescriptionIncludes:description: (in category 'accessing') -----
should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString)
description: aString
!
----- Method: TestCase>>should:raise:withExceptionDo: (in category 'extensions') -----
should: aBlock raise: anException withExceptionDo: anotherBlock
^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)!
----- Method: TestCase>>shouldFix: (in category 'extensions') -----
shouldFix: aBlock
^self should: aBlock raise: Exception!
----- Method: TestCase>>shouldPass (in category 'testing') -----
shouldPass
"Unless the selector is in the list we get from #expectedFailures, we expect it to pass"
^ (self expectedFailures includes: testSelector) not!
----- Method: TestCase>>shouldnt: (in category 'accessing') -----
shouldnt: aBlock
self deny: aBlock value
!
----- Method: TestCase>>shouldnt:description: (in category 'accessing') -----
shouldnt: aBlock description: aString
self deny: aBlock value description: aString
!
----- Method: TestCase>>shouldnt:raise: (in category 'accessing') -----
shouldnt: aBlock raise: anExceptionalEvent
^ [ aBlock value ]
on: anExceptionalEvent
do: [:e | self fail: 'Block raised ', e className, ': ', e messageText].!
----- Method: TestCase>>shouldnt:raise:description: (in category 'accessing') -----
shouldnt: aBlock raise: anExceptionalEvent description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString
!
----- Method: TestCase>>shouldnt:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') -----
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not
description: aString
!
----- Method: TestCase>>shouldnt:raise:whoseDescriptionIncludes:description: (in category 'accessing') -----
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString
^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not
description: aString
!
----- Method: TestCase>>signalFailure: (in category 'accessing') -----
signalFailure: aString
TestResult failure signal: aString!
----- Method: TestCase>>tearDown (in category 'running') -----
tearDown!
----- Method: TestCase>>timeout: (in category 'accessing') -----
timeout: seconds
"The timeout for a test should normally be set with a method annotation.
However, for tests that are expected to run in images that do not support
method annotations, the value may be set by setting the value from the
#setUp method (i.e. prior to running the test method)."
timeout := seconds!
----- Method: TestCase>>timeout:after: (in category 'running') -----
timeout: aBlock after: seconds
"Evaluate the argument block. Time out if the evaluation is not
complete after the given number of seconds. Handle the situation
that a timeout may occur after a failure (during debug)"
| theProcess delay watchdog |
"the block will be executed in the current process"
theProcess := Processor activeProcess.
delay := Delay forSeconds: seconds.
"make a watchdog process"
watchdog := [
delay wait. "wait for timeout or completion"
theProcess ifNotNil:[ theProcess signalException:
(TestFailure new messageText: 'Test timed out') ]
] newProcess.
"Watchdog needs to run at high priority to do its job (but not at timing priority)"
watchdog priority: Processor timingPriority-1.
"catch the timeout signal"
watchdog resume. "start up the watchdog"
^[aBlock on: TestFailure, Error, Halt do:[:ex|
theProcess := nil.
ex pass.
]] ensure:[ "evaluate the receiver"
theProcess := nil. "it has completed, so ..."
delay delaySemaphore signal. "arrange for the watchdog to exit"
]!
----- Method: TestCase>>timeoutForSetUp (in category 'accessing') -----
timeoutForSetUp
"Answer the timeout to use for setUp"
| method |
method := self class lookupSelector: testSelector asSymbol.
(method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first].
^self defaultTimeout!
----- Method: TestCase>>timeoutForTest (in category 'accessing') -----
timeoutForTest
"Answer the timeout to use for this test"
| method |
method := self class lookupSelector: testSelector asSymbol.
(method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first].
^timeout ifNil: [self defaultTimeout]!
Object subclass: #TestResource
instanceVariableNames: 'name description'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
TestResource class
instanceVariableNames: 'current'!
TestResource class
instanceVariableNames: 'current'!
TestResource subclass: #SimpleTestResource
instanceVariableNames: 'runningState hasRun hasSetup hasRanOnce'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Tests'!
----- Method: SimpleTestResource>>hasRun (in category 'testing') -----
hasRun
^hasRun
!
----- Method: SimpleTestResource>>hasSetup (in category 'testing') -----
hasSetup
^hasSetup
!
----- Method: SimpleTestResource>>isAvailable (in category 'testing') -----
isAvailable
^self runningState == self startedStateSymbol
!
----- Method: SimpleTestResource>>runningState (in category 'accessing') -----
runningState
^runningState
!
----- Method: SimpleTestResource>>runningState: (in category 'accessing') -----
runningState: aSymbol
runningState := aSymbol
!
----- Method: SimpleTestResource>>setRun (in category 'running') -----
setRun
hasRun := true
!
----- Method: SimpleTestResource>>setUp (in category 'running') -----
setUp
self runningState: self startedStateSymbol.
hasSetup := true
!
----- Method: SimpleTestResource>>startedStateSymbol (in category 'running') -----
startedStateSymbol
^#started
!
----- Method: SimpleTestResource>>stoppedStateSymbol (in category 'running') -----
stoppedStateSymbol
^#stopped
!
----- Method: SimpleTestResource>>tearDown (in category 'running') -----
tearDown
self runningState: self stoppedStateSymbol
!
----- Method: TestResource class>>current (in category 'accessing') -----
current
^ current ifNil: [ current := self new]
!
----- Method: TestResource class>>current: (in category 'accessing') -----
current: aTestResource
current := aTestResource
!
----- Method: TestResource class>>isAbstract (in category 'testing') -----
isAbstract
"Override to true if a TestResource subclass is Abstract and should not have
TestCase instances built from it"
^self name = #TestResource
!
----- Method: TestResource class>>isAvailable (in category 'testing') -----
isAvailable
^self current notNil and: [self current isAvailable]
!
----- Method: TestResource class>>isUnavailable (in category 'testing') -----
isUnavailable
^self isAvailable not
!
----- Method: TestResource class>>reset (in category 'Creation') -----
reset
current ifNotNil: [:oldCurrent |
current := nil.
oldCurrent tearDown]!
----- Method: TestResource class>>resources (in category 'accessing') -----
resources
^#()
!
----- Method: TestResource class>>signalInitializationError (in category 'creation') -----
signalInitializationError
^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized'
!
----- Method: TestResource>>description (in category 'accessing') -----
description
^description ifNil: [ '' ]!
----- Method: TestResource>>description: (in category 'accessing') -----
description: aString
description := aString
!
----- Method: TestResource>>initialize (in category 'initializing') -----
initialize
super initialize.
self setUp
!
----- Method: TestResource>>isAvailable (in category 'testing') -----
isAvailable
"override to provide information on the
readiness of the resource"
^true
!
----- Method: TestResource>>isUnavailable (in category 'testing') -----
isUnavailable
"override to provide information on the
readiness of the resource"
^self isAvailable not
!
----- Method: TestResource>>name (in category 'accessing') -----
name
^name ifNil: [ self printString]!
----- Method: TestResource>>name: (in category 'accessing') -----
name: aString
name := aString
!
----- Method: TestResource>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: self class printString
!
----- Method: TestResource>>resources (in category 'accessing') -----
resources
^self class resources
!
----- Method: TestResource>>setUp (in category 'running') -----
setUp
"Does nothing. Subclasses should override this
to initialize their resource"
!
----- Method: TestResource>>signalInitializationError (in category 'running') -----
signalInitializationError
^self class signalInitializationError
!
----- Method: TestResource>>tearDown (in category 'running') -----
tearDown
"Does nothing. Subclasses should override this
to tear down their resource"
!
Object subclass: #TestResult
instanceVariableNames: 'timeStamp failures errors passed'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
!TestResult commentStamp: '<historical>' prior: 0!
This is a Collecting Parameter for the running of a bunch of tests. TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. Kent has seen TestResults that recorded coverage information and that sent email when they were done.!
----- Method: TestResult class>>error (in category 'exceptions') -----
error
^self exError
!
----- Method: TestResult class>>exError (in category 'exceptions') -----
exError
^Error
!
----- Method: TestResult class>>failure (in category 'exceptions') -----
failure
^TestFailure
!
----- Method: TestResult class>>historyAt: (in category 'history') -----
historyAt: aTestCaseClass
"I will return the last test dictionary for aTestCaseClass. If none found, I will create a new empty one and link it in the history."
^ aTestCaseClass history !
----- Method: TestResult class>>historyAt:put: (in category 'history') -----
historyAt: aTestCaseClass put: aDictionary
aTestCaseClass history: aDictionary
"^ self history at: aTestCaseClass put: aDictionary "!
----- Method: TestResult class>>historyFor: (in category 'history') -----
historyFor: aTestCaseClass
"I return the last test dictionary for aTestCaseClass.
If none found, I return an empty dictionary but will not link it to the class in the history."
| history |
history := aTestCaseClass history.
history ifNil: [ ^ self newTestDictionary ].
^ history
" ^ self history at: aTestCaseClass ifAbsent: [ self newTestDictionary ]"!
----- Method: TestResult class>>newTestDictionary (in category 'history') -----
newTestDictionary
^ Dictionary new at: #timeStamp put: TimeStamp now;
at: #passed put: Set new;
at: #failures put: Set new;
at: #errors put: Set new;
yourself
!
----- Method: TestResult class>>removeFromTestHistory:in: (in category 'history') -----
removeFromTestHistory: aSelector in: aTestCaseClass
| lastRun |
lastRun := self historyFor: aTestCaseClass.
#(#passed #failures #errors) do:
[ :set | (lastRun at: set) remove: aSelector ifAbsent: []].
!
----- Method: TestResult class>>resumableFailure (in category 'exceptions') -----
resumableFailure
^ResumableTestFailure
!
----- Method: TestResult class>>signalErrorWith: (in category 'exceptions') -----
signalErrorWith: aString
self error signal: aString
!
----- Method: TestResult class>>signalFailureWith: (in category 'exceptions') -----
signalFailureWith: aString
self failure signal: aString
!
----- Method: TestResult class>>updateTestHistoryFor:status: (in category 'history') -----
updateTestHistoryFor: aTestCase status: aSymbol
| cls sel |
cls := aTestCase class.
sel := aTestCase selector.
self removeFromTestHistory: sel in: cls.
((self historyAt: cls) at: aSymbol ) add: sel!
----- Method: TestResult>>classesTested (in category 'accessing') -----
classesTested
^ (self tests collect: [ :testCase | testCase class ]) asSet!
----- Method: TestResult>>correctCount (in category 'accessing') -----
correctCount
"depreciated - use #passedCount"
^self passedCount
!
----- Method: TestResult>>defects (in category 'accessing') -----
defects
^OrderedCollection new
addAll: self errors;
addAll: self failures; yourself
!
----- Method: TestResult>>diff: (in category 'diff') -----
diff: aTestResult
"Return a collection that contains differences"
| passed1Selectors failed1Selectors errors1Selectors passed2Selectors failed2Selectors errors2Selectors |
passed1Selectors := self passed collect: [:testCase | testCase selector].
failed1Selectors := self failures collect: [:testCase | testCase selector].
errors1Selectors := self errors collect: [:testCase | testCase selector].
passed2Selectors := aTestResult passed collect: [:testCase | testCase selector].
failed2Selectors := aTestResult failures collect: [:testCase | testCase selector].
errors2Selectors := aTestResult errors collect: [:testCase | testCase selector].
^ {passed1Selectors copyWithoutAll: passed2Selectors .
failed1Selectors copyWithoutAll: failed2Selectors .
errors1Selectors copyWithoutAll: errors2Selectors}!
----- Method: TestResult>>dispatchResultsIntoHistory (in category 'history') -----
dispatchResultsIntoHistory
self classesTested do:
[ :testClass |
self class
historyAt: testClass
put: (self selectResultsForTestCase: testClass) ].
!
----- Method: TestResult>>errorCount (in category 'accessing') -----
errorCount
^self errors size
!
----- Method: TestResult>>errors (in category 'compatibility') -----
errors
^ self unexpectedErrors!
----- Method: TestResult>>expectedDefectCount (in category 'accessing') -----
expectedDefectCount
^ self expectedDefects size!
----- Method: TestResult>>expectedDefects (in category 'accessing') -----
expectedDefects
^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] !
----- Method: TestResult>>expectedPassCount (in category 'accessing') -----
expectedPassCount
^ self expectedPasses size!
----- Method: TestResult>>expectedPasses (in category 'accessing') -----
expectedPasses
^ passed select: [:each | each shouldPass] !
----- Method: TestResult>>failureCount (in category 'accessing') -----
failureCount
^self failures size
!
----- Method: TestResult>>failures (in category 'compatibility') -----
failures
^ self unexpectedFailures, self unexpectedPasses !
----- Method: TestResult>>hasErrors (in category 'testing') -----
hasErrors
^self errors size > 0
!
----- Method: TestResult>>hasFailures (in category 'testing') -----
hasFailures
^self failures size > 0
!
----- Method: TestResult>>hasPassed (in category 'testing') -----
hasPassed
^ self hasErrors not and: [ self hasFailures not ]!
----- Method: TestResult>>initialize (in category 'initialization') -----
initialize
super initialize.
passed := OrderedCollection new.
failures := Set new.
errors := OrderedCollection new.
timeStamp := TimeStamp now!
----- Method: TestResult>>isError: (in category 'testing') -----
isError: aTestCase
^self errors includes: aTestCase
!
----- Method: TestResult>>isErrorFor:selector: (in category 'querying') -----
isErrorFor: class selector: selector
^ self errors anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]!
----- Method: TestResult>>isFailure: (in category 'testing') -----
isFailure: aTestCase
^self failures includes: aTestCase
!
----- Method: TestResult>>isFailureFor:selector: (in category 'querying') -----
isFailureFor: class selector: selector
^ self failures anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]!
----- Method: TestResult>>isPassed: (in category 'testing') -----
isPassed: aTestCase
^self passed includes: aTestCase
!
----- Method: TestResult>>isPassedFor:selector: (in category 'querying') -----
isPassedFor: class selector: selector
^ self passed anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]!
----- Method: TestResult>>passed (in category 'compatibility') -----
passed
^ self expectedPasses, self expectedDefects!
----- Method: TestResult>>passedCount (in category 'accessing') -----
passedCount
^self passed size
!
----- Method: TestResult>>printOn: (in category 'printing') -----
printOn: aStream
aStream
nextPutAll: self runCount printString;
nextPutAll: ' run, ';
nextPutAll: self expectedPassCount printString;
nextPutAll: ' passes, ';
nextPutAll: self expectedDefectCount printString;
nextPutAll:' expected failures, ';
nextPutAll: self unexpectedFailureCount printString;
nextPutAll: ' failures, ';
nextPutAll: self unexpectedErrorCount printString;
nextPutAll:' errors, ';
nextPutAll: self unexpectedPassCount printString;
nextPutAll:' unexpected passes'.!
----- Method: TestResult>>runCase: (in category 'running') -----
runCase: aTestCase
| testCasePassed |
testCasePassed := true.
[[aTestCase runCase]
on: self class failure
do:
[:signal |
failures add: aTestCase.
testCasePassed := false.
signal return: false]]
on: self class error
do:
[:signal |
errors add: aTestCase.
testCasePassed := false.
signal return: false].
testCasePassed ifTrue: [passed add: aTestCase]!
----- Method: TestResult>>runCount (in category 'accessing') -----
runCount
^ passed size + failures size + errors size!
----- Method: TestResult>>selectResultsForTestCase: (in category 'history') -----
selectResultsForTestCase: aTestCaseClass
| passedSelectors errorsSelectors failuresSelectors |
passedSelectors := self passed
select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector].
errorsSelectors := self errors
select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector].
failuresSelectors := self failures
select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector].
^ self class newTestDictionary
at: #passed put: passedSelectors asSet;
at: #failures put: failuresSelectors asSet;
at: #errors put: errorsSelectors asSet;
yourself
!
----- Method: TestResult>>tests (in category 'accessing') -----
tests
^(OrderedCollection new: self runCount)
addAll: passed;
addAll: failures;
addAll: errors;
yourself!
----- Method: TestResult>>timeStamp (in category 'accessing') -----
timeStamp
^ timeStamp!
----- Method: TestResult>>timeStamp: (in category 'accessing') -----
timeStamp: anObject
timeStamp := anObject!
----- Method: TestResult>>unexpectedErrorCount (in category 'accessing') -----
unexpectedErrorCount
^ self unexpectedErrors size!
----- Method: TestResult>>unexpectedErrors (in category 'accessing') -----
unexpectedErrors
^ errors select: [:each | each shouldPass] !
----- Method: TestResult>>unexpectedFailureCount (in category 'accessing') -----
unexpectedFailureCount
^ self unexpectedFailures size!
----- Method: TestResult>>unexpectedFailures (in category 'accessing') -----
unexpectedFailures
^ failures select: [:each | each shouldPass] !
----- Method: TestResult>>unexpectedPassCount (in category 'accessing') -----
unexpectedPassCount
^ self unexpectedPasses size!
----- Method: TestResult>>unexpectedPasses (in category 'accessing') -----
unexpectedPasses
^ passed select: [:each | each shouldPass not] !
----- Method: TestResult>>updateResultsInHistory (in category 'history') -----
updateResultsInHistory
#(#passed #failures #errors) do: [ :status |
(self perform: status) do: [ :testCase |
self class updateTestHistoryFor: testCase status: status ] ]!
Object subclass: #TestSuite
instanceVariableNames: 'tests resources name'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnit-Kernel'!
!TestSuite commentStamp: '<historical>' prior: 0!
This is a Composite of Tests, either TestCases or other TestSuites. The common protocol is #run: aTestResult and the dependencies protocol!
----- Method: TestSuite class>>named: (in category 'instance creation') -----
named: aString
^self new
name: aString;
yourself
!
----- Method: TestSuite>>addDependentToHierachy: (in category 'dependencies') -----
addDependentToHierachy: anObject
self addDependent: anObject.
self tests do: [ :each | each addDependentToHierachy: anObject]
!
----- Method: TestSuite>>addTest: (in category 'accessing') -----
addTest: aTest
self tests add: aTest
!
----- Method: TestSuite>>addTests: (in category 'accessing') -----
addTests: aCollection
aCollection do: [:eachTest | self addTest: eachTest]
!
----- Method: TestSuite>>debug (in category 'running') -----
debug
self tests do:
[ : each | self changed: each.
each debug ]!
----- Method: TestSuite>>defaultResources (in category 'accessing') -----
defaultResources
^self tests
inject: Set new
into: [:coll :testCase |
coll
addAll: testCase resources;
yourself]
!
----- Method: TestSuite>>name (in category 'accessing') -----
name
^name
!
----- Method: TestSuite>>name: (in category 'accessing') -----
name: aString
name := aString
!
----- Method: TestSuite>>removeDependentFromHierachy: (in category 'dependencies') -----
removeDependentFromHierachy: anObject
self removeDependent: anObject.
self tests do: [ :each | each removeDependentFromHierachy: anObject]
!
----- Method: TestSuite>>resources (in category 'accessing') -----
resources
^ resources ifNil: [resources := self defaultResources]
!
----- Method: TestSuite>>resources: (in category 'accessing') -----
resources: anObject
resources := anObject
!
----- Method: TestSuite>>resultClass (in category 'private') -----
resultClass
^ TestResult.!
----- Method: TestSuite>>run (in category 'running') -----
run
| result |
result := self resultClass new.
self resources do: [ :res |
res isAvailable ifFalse: [^res signalInitializationError]].
[self run: result] ensure: [self resources do: [:each | each reset]].
^result
!
----- Method: TestSuite>>run: (in category 'running') -----
run: aResult
self tests do: [:each |
self changed: each.
each run: aResult].
!
----- Method: TestSuite>>tests (in category 'accessing') -----
tests
^ tests ifNil: [tests := OrderedCollection new]
!
More information about the Squeak-dev
mailing list
|