'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6497] on 5 December 2004 at 9:51:58 pm'! "Change Set: SUnit-md.22 Date: 5 December 2004 Author: Marcus Denker This is the changeset that Monticello builds if you load in SUnit.22 in 3.8gamma. Hand-tweaked a bit. So it's the diff. This should go in 3.8gamma and 3.9alpha"! TestCase subclass: #TestExceptionSubstrings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! Model subclass: #TestRunner instanceVariableNames: 'result details passFail failures errors tests passFailText detailsText lastPass testsList selectedFailureTest selectedErrorTest selectedSuite filter selectedSuites running runSemaphore completedTests totalTests progress ' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UI'! !TestRunner commentStamp: 'nk 8/6/2003 10:02' prior: 0! This is a user interface for the SUnit TestCase and TestSuite classes. It lets you run tests in the background, and you can select subsets to run.! !SUnitNameResolver class methodsFor: 'camp smalltalk' stamp: 'SSS 7/3/2000 11:11'! classNamed: aSymbol ^Smalltalk at: aSymbol ifAbsent: [nil].! ! !SUnitNameResolver class methodsFor: 'camp smalltalk' stamp: 'jp 3/17/2003 13:56'! defaultLogDevice ^ Transcript! ! !SUnitNameResolver class methodsFor: 'camp smalltalk' stamp: 'jp 3/17/2003 13:56'! errorObject ^Error! ! !SUnitNameResolver class methodsFor: 'camp smalltalk' stamp: 'jp 3/17/2003 13:56'! mnuExceptionObject ^MessageNotUnderstood new! ! !SUnitNameResolver class methodsFor: 'camp smalltalk' stamp: 'jp 3/17/2003 13:56'! notificationObject ^Notification new! ! !TestCase methodsFor: 'running'! debug self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. [(self class selector: testSelector) runCase] sunitEnsure: [self resources do: [:each | each reset]] ! ! !TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:13'! 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.! ! !TestCase methodsFor: 'running'! failureLog ^SUnitNameResolver defaultLogDevice ! ! !TestCase methodsFor: 'running'! isLogging "By default, we're not logging failures. If you override this in a subclass, make sure that you override #failureLog" ^false ! ! !TestCase methodsFor: 'running'! logFailure: aString self isLogging ifTrue: [ self failureLog cr; nextPutAll: aString; flush] ! ! !TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:17'! 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! ! !TestCase methodsFor: 'running'! run | result | result := TestResult new. self run: result. ^result ! ! !TestCase methodsFor: 'running'! run: aResult aResult runCase: self ! ! !TestCase methodsFor: 'running'! runCase [self setUp. self performTest] sunitEnsure: [self tearDown] ! ! !TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:13'! runCaseAsFailure: aSemaphore [self setUp. self openDebuggerOnFailingTestMethod] sunitEnsure: [ self tearDown. aSemaphore signal]! ! !TestCase methodsFor: 'running'! setUp ! ! !TestCase methodsFor: 'running'! tearDown ! ! !TestCase methodsFor: 'accessing'! assert: aBoolean aBoolean ifFalse: [self signalFailure: 'Assertion failed'] ! ! !TestCase methodsFor: 'accessing'! assert: aBoolean description: aString aBoolean ifFalse: [ self logFailure: aString. TestResult failure sunitSignalWith: aString] ! ! !TestCase methodsFor: 'accessing'! assert: aBoolean description: aString resumable: resumableBoolean | exception | aBoolean ifFalse: [self logFailure: aString. exception := resumableBoolean ifTrue: [TestResult resumableFailure] ifFalse: [TestResult failure]. exception sunitSignalWith: aString] ! ! !TestCase methodsFor: 'accessing'! deny: aBoolean self assert: aBoolean not ! ! !TestCase methodsFor: 'accessing'! deny: aBoolean description: aString self assert: aBoolean not description: aString ! ! !TestCase methodsFor: 'accessing'! deny: aBoolean description: aString resumable: resumableBoolean self assert: aBoolean not description: aString resumable: resumableBoolean ! ! !TestCase methodsFor: '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 ! ! !TestCase methodsFor: 'accessing'! selector ^testSelector ! ! !TestCase methodsFor: 'accessing'! should: aBlock self assert: aBlock value ! ! !TestCase methodsFor: 'accessing'! should: aBlock description: aString self assert: aBlock value description: aString ! ! !TestCase methodsFor: 'accessing'! should: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) ! ! !TestCase methodsFor: 'accessing'! should: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) description: aString ! ! !TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:32'! should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) description: aString ! ! !TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:24'! should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) description: aString ! ! !TestCase methodsFor: 'accessing'! shouldnt: aBlock self deny: aBlock value ! ! !TestCase methodsFor: 'accessing'! shouldnt: aBlock description: aString self deny: aBlock value description: aString ! ! !TestCase methodsFor: 'accessing'! shouldnt: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not ! ! !TestCase methodsFor: 'accessing'! shouldnt: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString ! ! !TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not description: aString ! ! !TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not description: aString ! ! !TestCase methodsFor: 'accessing'! signalFailure: aString TestResult failure sunitSignalWith: aString! ! !TestCase methodsFor: 'dependencies'! addDependentToHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ! !TestCase methodsFor: 'dependencies'! removeDependentFromHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ! !TestCase methodsFor: 'private'! executeShould: aBlock inScopeOf: anExceptionalEvent ^[aBlock value. false] sunitOn: anExceptionalEvent do: [:ex | ex sunitExitWith: true] ! ! !TestCase methodsFor: 'private' stamp: 'nk 5/11/2003 10:23'! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] sunitOn: anExceptionalEvent do: [:ex | ex sunitExitWith: (ex description includesSubString: aString) ] ! ! !TestCase methodsFor: 'private' stamp: 'nk 5/11/2003 10:32'! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] sunitOn: anExceptionalEvent do: [:ex | ex sunitExitWith: (ex description includesSubString: aString) not ] ! ! !TestCase methodsFor: 'private'! performTest self perform: testSelector sunitAsSymbol ! ! !TestCase methodsFor: 'private'! setTestSelector: aSymbol testSelector := aSymbol ! ! !TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:40'! expectedFailures ^ Array new! ! !TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:39'! shouldPass "Unless the selector is in the list we get from #expectedFailures, we expect it to pass" ^ (self expectedFailures includes: testSelector) not! ! !TestCase methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self class printString; nextPutAll: '>>#'; nextPutAll: testSelector ! ! !ExampleSetTest methodsFor: 'testing'! testAdd empty add: 5. self assert: (empty includes: 5) ! ! !ExampleSetTest methodsFor: 'testing'! testGrow empty addAll: (1 to: 100). self assert: empty size = 100 ! ! !ExampleSetTest methodsFor: 'testing'! testIllegal self should: [empty at: 5] raise: TestResult error. self should: [empty at: 5 put: #abc] raise: TestResult error ! ! !ExampleSetTest methodsFor: 'testing'! testIncludes self assert: (full includes: 5). self assert: (full includes: #abc) ! ! !ExampleSetTest methodsFor: 'testing'! testOccurrences self assert: (empty occurrencesOf: 0) = 0. self assert: (full occurrencesOf: 5) = 1. full add: 5. self assert: (full occurrencesOf: 5) = 1 ! ! !ExampleSetTest methodsFor: 'testing'! testRemove full remove: 5. self assert: (full includes: #abc). self deny: (full includes: 5) ! ! !ExampleSetTest methodsFor: 'running'! setUp empty := Set new. full := Set with: 5 with: #abc ! ! !LongTestCaseTest methodsFor: 'testing' stamp: 'md 12/5/2004 21:28'! testLongTestCaseRun "self debug: #testLongTestCaseRun" "self run: #testLongTestCaseRun" LongTestCase runLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self assert: LongTestCaseTestUnderTest hasRun. LongTestCase doNotRunLongTestCases. ! ! !LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'! testWhenRunMarkTestedToTrue RunStatus := true.! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! errorTest 1 zork ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! failureLog ^SUnitNameResolver defaultLogDevice ! ! !ResumableTestFailureTestCase methodsFor: '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 ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! isLogging ^false ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! okTest self assert: true ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! regularTestFailureTest self assert: false description: 'You should see me' ! ! !ResumableTestFailureTestCase methodsFor: '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 ! ! !ResumableTestFailureTestCase methodsFor: '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 ! ! !SUnitTest methodsFor: 'testing'! errorShouldntRaise self shouldnt: [self someMessageThatIsntUnderstood] raise: SUnitNameResolver notificationObject ! ! !SUnitTest methodsFor: 'testing'! testAssert self assert: true. self deny: false ! ! !SUnitTest methodsFor: '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 ! ! !SUnitTest methodsFor: 'testing'! testDialectLocalizedException self should: [TestResult signalFailureWith: 'Foo'] raise: TestResult failure. self should: [TestResult signalErrorWith: 'Foo'] raise: TestResult error. ! ! !SUnitTest methodsFor: '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 ! ! !SUnitTest methodsFor: 'testing'! testException self should: [self error: 'foo'] raise: TestResult error ! ! !SUnitTest methodsFor: 'testing'! testFail | case result | case := self class selector: #fail. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 1 errors: 0 ! ! !SUnitTest methodsFor: 'testing'! testIsNotRerunOnDebug | case | case := self class selector: #testRanOnlyOnce. case run. case debug ! ! !SUnitTest methodsFor: 'testing'! testRan | case | case := self class selector: #setRun. case run. self assert: case hasSetup. self assert: case hasRun ! ! !SUnitTest methodsFor: 'testing'! testRanOnlyOnce self assert: hasRanOnce ~= true. hasRanOnce := true ! ! !SUnitTest methodsFor: 'testing'! testResult | case result | case := self class selector: #noop. result := case run. self assertForTestResult: result runCount: 1 passed: 1 failed: 0 errors: 0 ! ! !SUnitTest methodsFor: 'testing'! testRunning (SUnitDelay forSeconds: 2) wait ! ! !SUnitTest methodsFor: 'testing'! testShould self should: [true]; shouldnt: [false] ! ! !SUnitTest methodsFor: '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 ! ! !SUnitTest methodsFor: '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 ! ! !SUnitTest methodsFor: 'private'! error 3 zork ! ! !SUnitTest methodsFor: 'private'! fail self assert: false ! ! !SUnitTest methodsFor: 'private'! noop ! ! !SUnitTest methodsFor: 'private'! setRun hasRun := true ! ! !SUnitTest methodsFor: 'accessing'! hasRun ^hasRun ! ! !SUnitTest methodsFor: 'accessing'! hasSetup ^hasSetup ! ! !SUnitTest methodsFor: 'running'! setUp hasSetup := true ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! dummy self assert: true ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! error 'foo' odd ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! fail self assert: false ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! setRun resource setRun ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! setUp resource := SimpleTestResource current ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! testRan | case | case := self class selector: #setRun. case run. self assert: resource hasSetup. self assert: resource hasRun ! ! !SimpleTestResourceTestCase methodsFor: '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 ! ! !SimpleTestResourceTestCase methodsFor: 'Not categorized'! testResourcesCollection | collection | collection := self resources. self assert: collection size = 1 ! ! !TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 10:59'! 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 ] ! ! !TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 10:51'! addToSuite: suite fromMethods: testMethods testMethods do: [ :selector | suite addTest: (self selector: selector) ]. ^suite! ! !TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 16:37'! addToSuiteFromSelectors: suite ^self addToSuite: suite fromMethods: (self shouldInheritSelectors ifTrue: [ self allTestSelectors ] ifFalse: [self testSelectors ])! ! !TestCase class methodsFor: 'building suites' stamp: 'nk 12/23/2002 07:40'! buildSuite | suite | suite _ TestSuite new. ^ self isAbstract ifTrue: [ suite name: self name asString. self allSubclasses do: [:each | each isAbstract ifFalse: [each addToSuiteFromSelectors: suite]]. suite] ifFalse: [self addToSuiteFromSelectors: suite]! ! !TestCase class methodsFor: 'building suites'! buildSuiteFromAllSelectors ^self buildSuiteFromMethods: self allTestSelectors ! ! !TestCase class methodsFor: 'building suites'! buildSuiteFromLocalSelectors ^self buildSuiteFromMethods: self testSelectors ! ! !TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 10:52'! buildSuiteFromMethods: testMethods | suite | suite _ (TestSuite new) name: self name asString; yourself. ^self addToSuite: suite fromMethods: testMethods! ! !TestCase class methodsFor: 'building suites'! buildSuiteFromSelectors ^self shouldInheritSelectors ifTrue: [self buildSuiteFromAllSelectors] ifFalse: [self buildSuiteFromLocalSelectors] ! ! !TestCase class methodsFor: 'building suites'! suiteClass ^TestSuite ! ! !TestCase class methodsFor: 'instance creation'! debug: aSymbol ^(self selector: aSymbol) debug ! ! !TestCase class methodsFor: 'instance creation'! run: aSymbol ^(self selector: aSymbol) run ! ! !TestCase class methodsFor: 'instance creation'! selector: aSymbol ^self new setTestSelector: aSymbol ! ! !TestCase class methodsFor: 'instance creation'! suite ^self buildSuite ! ! !TestCase class methodsFor: 'testing'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #TestCase ! ! !TestCase class methodsFor: '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)$" ! ! !TestCase class methodsFor: 'accessing'! allTestSelectors ^self sunitAllSelectors select: [:each | 'test*' sunitMatch: each] ! ! !TestCase class methodsFor: 'accessing'! resources ^#() ! ! !TestCase class methodsFor: 'accessing'! sunitVersion ^'3.1' ! ! !TestCase class methodsFor: 'accessing'! testSelectors ^self sunitSelectors select: [:each | 'test*' sunitMatch: each] ! ! !LongTestCase class methodsFor: 'accessing' stamp: 'md 12/5/2004 21:36'! allTestSelectors DoNotRunLongTestCases ifFalse: [ ^super testSelectors]. ^#().! ! !LongTestCase class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:31'! runLongTestCases DoNotRunLongTestCases := false.! ! !LongTestCase class methodsFor: 'instance creation' stamp: 'md 12/5/2004 21:34'! buildSuite | suite | suite _ TestSuite new. DoNotRunLongTestCases ifFalse: [ self addToSuiteFromSelectors: suite]. ^suite! ! !LongTestCase class methodsFor: 'testing' stamp: 'md 11/14/2004 21:34'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #LongTestCase ! ! !LongTestCaseTestUnderTest class methodsFor: 'Accessing' stamp: 'md 11/14/2004 21:37'! markAsNotRun ^ RunStatus := false! ! !SimpleTestResourceTestCase class methodsFor: 'Not categorized'! resources ^Set new add: SimpleTestResource; yourself ! ! !TestExceptionSubstrings methodsFor: 'as yet unclassified' stamp: 'nk 5/11/2003 10:33'! testExceptionWithMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! ! !TestExceptionSubstrings methodsFor: 'as yet unclassified' stamp: 'nk 5/11/2003 10:33'! testExceptionWithoutMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'! ! !TestExceptionSubstrings methodsFor: 'as yet unclassified' stamp: 'nk 5/11/2003 10:34'! testNoExceptionWithMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'! ! !TestExceptionSubstrings methodsFor: 'as yet unclassified' stamp: 'nk 5/11/2003 10:35'! testNoExceptionWithNoMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'! ! !TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 1/24/2003 19:23'! defaultAction Processor activeProcess debug: self signalerContext title: self description! ! !TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 2/1/2003 00:58'! isResumable ^ false! ! !ResumableTestFailure methodsFor: 'camp smalltalk'! isResumable "Of course a ResumableTestFailure is resumable ;-)" ^true! ! !ResumableTestFailure methodsFor: 'camp smalltalk'! sunitExitWith: aValue self resume: aValue! ! !TestResource methodsFor: 'accessing'! description description isNil ifTrue: [^'']. ^description ! ! !TestResource methodsFor: 'accessing'! description: aString description := aString ! ! !TestResource methodsFor: 'accessing'! name name isNil ifTrue: [^self printString]. ^name ! ! !TestResource methodsFor: 'accessing'! name: aString name := aString ! ! !TestResource methodsFor: 'accessing'! resources ^self class resources ! ! !TestResource methodsFor: 'testing'! isAvailable "override to provide information on the readiness of the resource" ^true ! ! !TestResource methodsFor: 'testing'! isUnavailable "override to provide information on the readiness of the resource" ^self isAvailable not ! ! !TestResource methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self class printString ! ! !TestResource methodsFor: 'running'! setUp "Does nothing. Subclasses should override this to initialize their resource" ! ! !TestResource methodsFor: 'running'! signalInitializationError ^self class signalInitializationError ! ! !TestResource methodsFor: 'running'! tearDown "Does nothing. Subclasses should override this to tear down their resource" ! ! !TestResource methodsFor: 'initializing'! initialize self setUp ! ! !TestResource class methodsFor: 'accessing'! current current isNil ifTrue: [current := self new]. ^current ! ! !TestResource class methodsFor: 'accessing'! current: aTestResource current := aTestResource ! ! !TestResource class methodsFor: 'accessing'! resources ^#() ! ! !TestResource class methodsFor: 'testing'! isAbstract "Override to true if a TestResource subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #TestResource ! ! !TestResource class methodsFor: 'testing'! isAvailable ^self current notNil and: [self current isAvailable] ! ! !TestResource class methodsFor: 'testing'! isUnavailable ^self isAvailable not ! ! !TestResource class methodsFor: 'creation'! reset current notNil ifTrue: [ [current tearDown] ensure: [ current := nil]] ! ! !TestResource class methodsFor: 'creation'! signalInitializationError ^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized' ! ! !TestResult methodsFor: 'accessing'! correctCount "depreciated - use #passedCount" ^self passedCount ! ! !TestResult methodsFor: 'accessing'! defects ^OrderedCollection new addAll: self errors; addAll: self failures; yourself ! ! !TestResult methodsFor: 'accessing'! errorCount ^self errors size ! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! expectedDefectCount ^ self expectedDefects size! ! !TestResult methodsFor: 'accessing' stamp: 'md 11/25/2004 16:36'! expectedDefects ^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! expectedPassCount ^ self expectedPasses size! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! expectedPasses ^ passed select: [:each | each shouldPass] ! ! !TestResult methodsFor: 'accessing'! failureCount ^self failures size ! ! !TestResult methodsFor: 'accessing'! passedCount ^self passed size ! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:07'! runCount ^ passed size + failures size + errors size! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:06'! tests ^(OrderedCollection new: self runCount) addAll: passed; addAll: failures; addAll: errors; yourself! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! unexpectedErrorCount ^ self unexpectedErrors size! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! unexpectedErrors ^ errors select: [:each | each shouldPass] ! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! unexpectedFailureCount ^ self unexpectedFailures size! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! unexpectedFailures ^ failures select: [:each | each shouldPass] ! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! unexpectedPassCount ^ self unexpectedPasses size! ! !TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! unexpectedPasses ^ passed select: [:each | each shouldPass not] ! ! !TestResult methodsFor: 'testing'! hasErrors ^self errors size > 0 ! ! !TestResult methodsFor: 'testing'! hasFailures ^self failures size > 0 ! ! !TestResult methodsFor: 'testing' stamp: 'JF 7/30/2003 14:04'! hasPassed ^self runCount = (self passedCount + self expectedDefectCount)! ! !TestResult methodsFor: 'testing'! isError: aTestCase ^self errors includes: aTestCase ! ! !TestResult methodsFor: 'testing'! isFailure: aTestCase ^self failures includes: aTestCase ! ! !TestResult methodsFor: 'testing'! isPassed: aTestCase ^self passed includes: aTestCase ! ! !TestResult methodsFor: 'initialize-release' stamp: 'md 11/25/2004 16:23'! initialize passed _ OrderedCollection new. failures _ Set new. errors _ OrderedCollection new.! ! !TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:09'! errors ^ self unexpectedErrors! ! !TestResult methodsFor: 'compatibility' stamp: 'md 11/25/2004 16:23'! failures ^ self unexpectedFailures, self unexpectedPasses ! ! !TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:08'! passed ^ self expectedPasses, self expectedDefects! ! !TestResult methodsFor: 'printing' stamp: 'JF 7/30/2003 16:15'! 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'.! ! !TestResult methodsFor: 'running' stamp: 'JF 7/30/2003 16:05'! runCase: aTestCase | testCasePassed | testCasePassed := true. [[aTestCase runCase] sunitOn: self class failure do: [:signal | failures add: aTestCase. testCasePassed := false. signal sunitExitWith: false]] sunitOn: self class error do: [:signal | errors add: aTestCase. testCasePassed := false. signal sunitExitWith: false]. testCasePassed ifTrue: [passed add: aTestCase]! ! !TestResult class methodsFor: 'exceptions'! error ^self exError ! ! !TestResult class methodsFor: 'exceptions'! exError ^SUnitNameResolver errorObject ! ! !TestResult class methodsFor: 'exceptions'! failure ^TestFailure ! ! !TestResult class methodsFor: 'exceptions'! resumableFailure ^ResumableTestFailure ! ! !TestResult class methodsFor: 'exceptions'! signalErrorWith: aString self error sunitSignalWith: aString ! ! !TestResult class methodsFor: 'exceptions'! signalFailureWith: aString self failure sunitSignalWith: aString ! ! !TestRunner methodsFor: 'constants' stamp: 'ar 3/3/2004 00:05'! runButtonState ^running! ! !TestRunner methodsFor: 'initialize' stamp: 'ar 3/3/2004 00:01'! initialize result := TestResult new. passFail := 'N/A'. details := '...'. failures := OrderedCollection new. errors := OrderedCollection new. tests := self gatherTestNames. selectedSuite := 0. selectedFailureTest := 0. selectedErrorTest := 0. selectedSuites := tests collect: [:ea | true]. running := false.! ! !TestRunner methodsFor: 'initialize' stamp: 'md 11/14/2004 21:04'! testCases Preferences testRunnerShowAbstractClasses ifTrue: [ ^ TestCase allSubclasses. ]. ^ TestCase allSubclasses reject: [:cls | cls isAbstract]! ! !TestRunner methodsFor: 'interface opening' stamp: 'md 11/10/2004 13:36'! buildDetailsText detailsText _ PluggableTextMorph on: self text: #details accept: nil. detailsText hideScrollBarsIndefinitely. ^detailsText! ! !TestRunner methodsFor: 'interface opening' stamp: 'md 11/10/2004 13:35'! buildPassFailText passFailText _ PluggableTextMorph on: self text: #passFail accept: nil. passFailText hideScrollBarsIndefinitely. ^ passFailText! ! !TestRunner methodsFor: 'interface opening' stamp: 'ar 3/3/2004 00:04'! updateProgressWatcher: text progress subLabel: text. progress done: (completedTests / totalTests) asFloat. World doOneCycleNow. running ifFalse:[self error:'Run stopped'].! ! !TestRunner methodsFor: 'menus' stamp: 'ar 3/3/2004 23:56'! listMenu: aMenu shifted: shiftState aMenu title: 'Test Cases'. aMenu add: 'select all' target: self selector: #selectAll. aMenu add: 'deselect all' target: self selector: #deselectAll. aMenu add: 'toggle selections' target: self selector: #toggleSelections. aMenu add: 'filter' target: self selector: #setFilter. selectedSuite > 0 ifTrue: [ | cls | cls _ (tests at: selectedSuite ifAbsent: ['']) copyUpTo: Character space. cls _ cls asSymbol. cls _ (Smalltalk at: cls ifAbsent: []). cls ifNotNil: [ | mtc | aMenu addLine. aMenu add: 'browse' target: self selector: #browse: argument: cls. mtc _ Smalltalk at: #MorphicTestCase ifAbsent: [ ]. (mtc notNil and: [ cls inheritsFrom: mtc ]) ifTrue: [ aMenu add: 'record interaction' target: self selector: #recordInteractionFor: argument: cls. ]. ]. ]. shiftState ifTrue: [ aMenu addLine. testsList addCustomMenuItems: aMenu hand: ActiveHand. ]. ^aMenu ! ! !TestRunner methodsFor: 'menus' stamp: 'ar 3/3/2004 00:01'! terminateRun running := false.! ! !TestRunner methodsFor: 'processing' stamp: 'ar 3/1/2004 03:29'! runOneTest | testSuite | Cursor execute showWhile: [ self runWindow. selectedSuite isZero ifTrue: [ ^ self displayPassFail: 'No Test Suite Selected' ]. testSuite _ TestSuite new name: 'TestRunner Suite'. self addTestsFor: (tests at: selectedSuite) toSuite: testSuite. self runSuite: testSuite. ]! ! !TestRunner methodsFor: 'processing' stamp: 'ar 3/3/2004 00:05'! runSuite: suite suite addDependent: self. totalTests _ suite tests size. completedTests _ 0. self installProgressWatcher. self runWindow. self changed: #runTests. self changed: #runOneTest. running := true. [ result _ suite run ] ensure: [ suite removeDependent: self. self removeProgressWatcher. self updateWindow: result. self changed: #runTests. self changed: #runOneTest. ]. ! ! !TestRunner methodsFor: 'updating' stamp: 'ar 3/1/2004 03:21'! update: aParameter "updates come in from another thread" (aParameter isKindOf: TestCase) ifTrue:[completedTests _ completedTests + 1. self updateProgressWatcher: aParameter printString] ifFalse: [ super update: aParameter ]! ! !TestRunner class methodsFor: 'class initialization' stamp: 'md 11/14/2004 21:02'! initialize "TestRunner initialize" self registerInFlapsRegistry. self registerPreferences. (Preferences windowColorFor: #TestRunner) = Color white ifTrue: [ Preferences setWindowColorFor: #TestRunner to: (Color colorFrom: self windowColorSpecification pastelColor) ]. (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu unregisterOpenCommand: 'Test Runner'. TheWorldMenu registerOpenCommand: {'SUnit Test Runner'. {self. #open}}]. ! ! !TestRunner class methodsFor: 'class initialization' stamp: 'md 11/14/2004 21:06'! registerPreferences "Registers a preference to run abstract test classes" Preferences addPreference: #testRunnerShowAbstractClasses categories: #(#sunit ) default: false balloonHelp: 'If true, the test testrunner shows abstract classes' ! ! !TestSuite methodsFor: 'dependencies'! addDependentToHierachy: anObject self sunitAddDependent: anObject. self tests do: [ :each | each addDependentToHierachy: anObject] ! ! !TestSuite methodsFor: 'dependencies'! removeDependentFromHierachy: anObject self sunitRemoveDependent: anObject. self tests do: [ :each | each removeDependentFromHierachy: anObject] ! ! !TestSuite methodsFor: 'accessing'! addTest: aTest self tests add: aTest ! ! !TestSuite methodsFor: 'accessing'! addTests: aCollection aCollection do: [:eachTest | self addTest: eachTest] ! ! !TestSuite methodsFor: 'accessing'! defaultResources ^self tests inject: Set new into: [:coll :testCase | coll addAll: testCase resources; yourself] ! ! !TestSuite methodsFor: 'accessing'! name ^name ! ! !TestSuite methodsFor: 'accessing'! name: aString name := aString ! ! !TestSuite methodsFor: 'accessing'! resources resources isNil ifTrue: [resources := self defaultResources]. ^resources ! ! !TestSuite methodsFor: 'accessing'! resources: anObject resources := anObject ! ! !TestSuite methodsFor: 'accessing'! tests tests isNil ifTrue: [tests := OrderedCollection new]. ^tests ! ! !TestSuite methodsFor: 'running'! run | result | result := TestResult new. self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. [self run: result] sunitEnsure: [self resources do: [:each | each reset]]. ^result ! ! !TestSuite methodsFor: 'running'! run: aResult self tests do: [:each | self sunitChanged: each. each run: aResult] ! ! !TestSuite class methodsFor: 'instance creation'! named: aString ^self new name: aString; yourself ! ! !TestSuite class reorganize! ('instance creation' named:) ! !TestSuite reorganize! ('dependencies' addDependentToHierachy: removeDependentFromHierachy:) ('accessing' addTest: addTests: defaultResources name name: resources resources: tests) ('running' run run:) ! TestRunner initialize! TestRunner removeSelector: #runSemaphore! Model subclass: #TestRunner instanceVariableNames: 'result details passFail failures errors tests passFailText detailsText lastPass testsList selectedFailureTest selectedErrorTest selectedSuite filter selectedSuites running completedTests totalTests progress' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UI'! !TestResult reorganize! ('accessing' correctCount defects errorCount expectedDefectCount expectedDefects expectedPassCount expectedPasses failureCount passedCount runCount tests unexpectedErrorCount unexpectedErrors unexpectedFailureCount unexpectedFailures unexpectedPassCount unexpectedPasses) ('testing' hasErrors hasFailures hasPassed isError: isFailure: isPassed:) ('initialize-release' initialize) ('compatibility' errors failures passed) ('printing' printOn:) ('running' runCase:) ! !TestResource reorganize! ('accessing' description description: name name: resources) ('testing' isAvailable isUnavailable) ('printing' printOn:) ('running' setUp signalInitializationError tearDown) ('initializing' initialize) ! !ResumableTestFailure reorganize! ('camp smalltalk' isResumable sunitExitWith:) ! !TestFailure reorganize! ('camp smalltalk' defaultAction isResumable) ! LongTestCase class removeSelector: #suite! !SUnitTest reorganize! ('testing' errorShouldntRaise testAssert testDefects testDialectLocalizedException testError testException testFail testIsNotRerunOnDebug testRan testRanOnlyOnce testResult testRunning testShould testSuite) ('private' assertForTestResult:runCount:passed:failed:errors: error fail noop setRun) ('accessing' hasRun hasSetup) ('running' setUp) ! !ExampleSetTest reorganize! ('testing' testAdd testGrow testIllegal testIncludes testOccurrences testRemove) ('running' setUp) ! TestCase removeSelector: #openDebuggerOnFailingTestMethod:! !TestCase reorganize! ('running' debug debugAsFailure failureLog isLogging logFailure: openDebuggerOnFailingTestMethod run run: runCase runCaseAsFailure: setUp tearDown) ('accessing' assert: assert:description: assert:description:resumable: deny: deny:description: deny:description:resumable: resources selector should: should:description: should:raise: should:raise:description: should:raise:whoseDescriptionDoesNotInclude:description: should:raise:whoseDescriptionIncludes:description: shouldnt: shouldnt:description: shouldnt:raise: shouldnt:raise:description: shouldnt:raise:whoseDescriptionDoesNotInclude:description: shouldnt:raise:whoseDescriptionIncludes:description: signalFailure:) ('dependencies' addDependentToHierachy: removeDependentFromHierachy:) ('private' executeShould:inScopeOf: executeShould:inScopeOf:withDescriptionContaining: executeShould:inScopeOf:withDescriptionNotContaining: performTest setTestSelector:) ('testing' expectedFailures shouldPass) ('printing' printOn:) ! !SUnitNameResolver class reorganize! ('camp smalltalk' classNamed: defaultLogDevice errorObject mnuExceptionObject notificationObject) !