Squeak 4.6: SUnit-mt.102.mcz
Locked
 
|
Chris Muller uploaded a new version of SUnit to project Squeak 4.6:
http://source.squeak.org/squeak46/SUnit-mt.102.mcz ==================== Summary ==================== Name: SUnit-mt.102 Author: mt Time: 19 April 2015, 7:24:35.203 am UUID: 3e115dcf-b404-3043-814e-ecb6f43f9192 Ancestors: SUnit-bf.101 Extracted logic of being a test method to be easier reusable in extensions and tools. Moved test-class-check from SUnitTools to here. ==================== Snapshot ==================== SystemOrganization addCategory: #'SUnit-Extensions'! SystemOrganization addCategory: #'SUnit-Kernel'! SystemOrganization addCategory: #'SUnit-Tests'! ----- Method: CompiledMethod>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self methodClass isTestClass and: [self selector isTestSelector]! 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! ----- Method: MethodReference>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self compiledMethod isTestMethod! ----- Method: Symbol>>isTestSelector (in category '*SUnit-testing') ----- isTestSelector ^ self beginsWith: 'test'! 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! ----- Method: Object>>isTestClass (in category '*SUnit-testing') ----- isTestClass ^ false! 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 uncategorisedMethods | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. uncategorisedMethods := self targetClass organization listAtCategoryNamed: #'as yet unclassified'. self assert: slips isEmpty description: ('{1} has uncategorised methods: {2}' format: {self targetClass. (uncategorisedMethods collect: #printString) asCommaString}).! 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 isTestSelector 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>>isTestClass (in category 'testing') ----- isTestClass ^ true! ----- 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] ! |
«
Return to Squeak - Dev
|
1 view|%1 views
| Free forum by Nabble | Edit this page |