!STB 0 F Package6StringTestFrameworkExtensionsr=D:\Dolphin Smalltalk\2.1\Packages\TestFrameworkExtensions.pacrThis package contains extensions to the basic TestingFramework provided by Kent Beck. The extensions in the package provide a GUI from which test cases may be run and results reviewed. When one or more test cases are run, a percentage of the number of correct test cases is displayed. If the result is less than 100%, the value is displayed in red, otherwise it is displayed in black. The GUI provides a way to quickly browse the methods which comprise the test cases, as well as a means to see the individual test results. This code may be used free of charge, but may not be included in any software package without permission of the author. Copyright (C) 1998, Allen Creek Software, Inc. All rights reserved.STBCollectionProxy STBClassProxyr IdentitySet&ArraySTBSymbolProxyrTestResultCollection*rExtendedListModel*rTestSuiteShell*rTestSuiteModel*rTestResultCollectionTestCase*rTestResultsPresenterrSet! Association*rClass*r testCaseName2*rSequenceableCollection*rasExtendedListModel2*r asListModel2*rTestCase*rselector2 p2rTestSuite class*rallTestCaseClasses2rTestSuite class*rrunAllTestCases2rTestCase class*rtestCaseSelectors2rTestCase class*rvalue:2rTestSuite class*r runTestCases:2rTestSuite class*rrunTestCasesFor:2rTestSuite class*r testCasesFor:2rTestCase class*rnumberOfTestCaseSelectors2*r TestFailure*r testMethod2*rexceptionDescription2*rrun2@2*r TestSuite*r numberOfTests2p2rTestCase class*rtestCaseMethods2rTestCase class*r testCases2*r MethodBrowser*rsaveCurrentMethod2rListModel class*r emptyList2*r TestResult*rnumberOfFailures2*rremoveFailureOrError:2*r wasFailure2`2*rsetTest:2*rerrors2*rfailures2*r hasErrors2*r hasFailures2*rnumberOfErrorsrTestingFrameworkrDolphinSTBIdentityDictionaryProxyrIdentityDictionary*r preinstallrObject subclass: #TestResult instanceVariableNames: 'startTime stopTime testName failures errors numberOfTests' classVariableNames: '' poolDictionaries: ''*r postinstallr*r preuninstall *r postuninstall  Object subclass: #TestResultCollection instanceVariableNames: 'testResults errors failures' classVariableNames: '' poolDictionaries: ''! ListModel subclass: #ExtendedListModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: ''! Model subclass: #TestSuiteModel instanceVariableNames: 'results filter' classVariableNames: '' poolDictionaries: ''! CompositePresenter subclass: #TestResultsPresenter instanceVariableNames: 'failurePresenter errorPresenter' classVariableNames: '' poolDictionaries: ''! Shell subclass: #TestSuiteShell instanceVariableNames: 'testCases testCasePresenter resultsPresenter percentagePresenter packagesPresenter methodBrowser' classVariableNames: '' poolDictionaries: ''! TestCase subclass: #TestResultCollectionTestCase instanceVariableNames: 'testResultCollection' classVariableNames: '' poolDictionaries: ''! 'end-class-definition'! XResourceIdentifierrTestSuiteShellr DefaultViewF ViewResource$STBResourceSTBByteArrayAccessorProxy6 ByteArray2!STB 0 N STBViewProxy STBClassProxy6String ShellView&Array`RGBPoint  BorderLayoutZz ContainerView `6 LargeIntegerD@ FramingLayoutSTBIdentityDictionaryProxyz LookupTableZz PushButton@ D0'STBSymbolProxyexitMessageSequenceSTBCollectionProxyzOrderedCollection MessageSendcreateAt:extent:go=0Benable:0B contextMenu:0Btext:&Close0WINDOWPLACEMENT6 ByteArray,,37yUFramingConstraintsfixedViewRightufixedParentRightfixedParentBottom@Zz StaticText@D`FontLOGFONT<"ArialxB15'U?R' NumberToTextB`}3`B`B`B@`,, #fixedParentLeft}fixedParentTopGZ@@ D'runB`o=BBB@&Run,,7.U  a@@Zp@DP <"ArialxB15'U?R' NullConverterB`_3P BP BP B@Percentage Correct:P ,, #sGzIdentityDictionary` resultsValuerunB`@B@B@B@@,,~*P `0ZzMultipleSelectionListBox` 1D  ListModel(zBasicListAbstract B` B B B@ BselectionByIndex: BhorizontalExtent: ,,~0  testCases0B` `B`B`B@Run Test Cases`B@Run Test Cases`BmenuBar:`,, O @Iconr ShellView.icoSTBExternalResourceLibraryProxyr DolphinDevRes r Card View2 Z r `!STB 0 N STBViewProxy STBClassProxy6String ShellView&Array`RGBPoint? ShieldLayoutSTBIdentityDictionaryProxyzIdentityDictionaryZz CardContainer`6 LargeIntegerD CardLayoutSTBCollectionProxyzOrderedCollection Association Test CasesZz ContainerView D BorderLayoutZ D  FramingLayoutJz LookupTableZz StaticText DFontLOGFONT6 ByteArray<"ArialxB15'U?Kw NumberToTextMessageSequence*@ MessageSendSTBSymbolProxycreateAt:extent:w3WINDOWPLACEMENTr,,!*@FramingConstraintsJfixedParentLeftwJfixedParentTop0CZ DP2Rr<"ArialxB15'U?Kw NullConverter*@"P _3P"Jtext:Percentage Correct:Pr,, *@ k00AZz PushButton  D:wJrun*@"Pio="&Runr,,47zU*@JfixedParentRightp aJfixedParentBottom Z  D :wJexit*@"Po= "&Close r,,7U*@JfixedViewRightup J`run percentage*@"P r,, f*@P Z D ProportionalLayoutJZzSplitter  D *@"Pc r,, *@ZzMultipleSelectionListBox  1D  ListModel*@ۊwzTestCase *@"Pi- "JselectionByIndex: "JhorizontalExtent: r,, *@Fraction Z   1D *@ۊwzBasicListAbstract *@"Pc""0r,, *@ J` testCasespackages*@"P r,, *@ J`*@"P 5r,,*@ rResultsZz ReferenceView D ResourceIdentifierzTestResultsPresenter DefaultView*@"P 5 r,,rMethodsZ0 Dz MethodBrowserBasic method browser*@"P 5r,,`J`methods  testResultsZzTabViewD *@ SystemColorM zIconicListAbstractSTBSingletonProxyzIconImageManagerJcurrentJnoIcons*@"P "r,,*@*@"P r,,*@ cards *@"P?`"Run Test Cases`"JmenuBar:`r,, *@ r ShellView.ico r DolphinDevRes rTestResultsPresenterr DefaultView2 Z r !STB 0 N STBViewProxy STBClassProxy6String ContainerView&Array 6 LargeIntegerD`ProportionalLayoutSTBIdentityDictionaryProxyz LookupTableZzSplitter `DpMessageSequenceSTBCollectionProxyzOrderedCollection MessageSendSTBSymbolProxycreateAt:extent:PointWpBjenable:pBj contextMenu:pBjtext:pWINDOWPLACEMENT6 ByteArray,,*zIdentityDictionaryBp`B`B `B``,, cZ `DPRGB FramingLayout*@ZzListViewPMD ListModelMenuCommandMenuItemFCommandDescriptionj runFailureRunjinspectFailureInspect:zBasicListAbstractzIconicListAbstractListViewColumn Test CasejleftzSortedCollectionMessagej testCaseNameMethod0RjselectorDescription of FailureY0RjexceptionDescriptionjreportBp3%BB B` Test CaseBjlvmSetExtendedListViewStyle:a,,FramingConstraintsjfixedParentLeftjfixedParentRightjfixedParentTop3jfixedParentBottomZz StaticTextPDp FontLOGFONT<"ArialB15'U?Kw NullConverterBp)p Bp B p B` Failures:p ,,t  0 0 -*failuresBpWPBPB PB`P,,p pZ `D*@Z Dp  <"ArialB15'U?Kwb Bp)pBpB pB`Errors:p,,B  0 0 /ZMDPRjrunErrorRunj inspectErrorInspect: Test Case0RpPMethod0RPDescription of ErrorY0R@ 0P` Bp3%PBPB PB` Test CasePBp aP,,  0 3P *PerrorsBp]WBB B`,,YPp rContainerView.ico TestResultCollection class instanceVariableNames: ''! TestResultCollection comment: ''! !TestResultCollection categoriesForClass!Testing Framework! ! !TestResultCollection methodsFor! add: aTestResult testResults add: aTestResult! allErrors "Answer a collection of all error test results." errors isNil ifTrue: [errors := self allOfType: #errors]. ^ errors! allFailures "Answer a collection of all failed test results." failures isNil ifTrue: [failures := self allOfType: #failures]. ^ failures ! allOfType: aSymbol "Answer a collection of all 'failed' test results based on the selector contained in aSymbol.." | result | result := OrderedCollection new. self testResults do: [:each | result addAll: (each perform: aSymbol)]. result := result asExtendedListModel. result when: #item:removedAtIndex: send: #onItem:removedAtIndex: to: self. ^ result! failure "Answer true if the receiver represents a successful test" ^ self wasSuccessful not! initialize testResults := OrderedCollection new.! numberOfBadResults | errorCount failureCount | errorCount := 0. failureCount := 0. self testResults do: [:each | errorCount := errorCount + each numberOfErrors. failureCount := failureCount + each numberOfFailures]. ^ errorCount + failureCount! onItem: aTestFailure removedAtIndex: anInteger (self removeFailureOrError: aTestFailure) isNil ifTrue: [^ self]. self trigger: #resultsChanged. ! percentCorrect "Answer the percentage of correct results." ^ ((1.0 - self percentFailed) * 100) roundTo: 0.1! percentFailed "Answer the percentage of failed results." self totalNumberOfTests <1 ifTrue: [^ 0.0]. ^ (self numberOfBadResults / self totalNumberOfTests) asFloat! removeFailureOrError: aTestFailure testResults do: [:each | (each removeFailureOrError: aTestFailure) notNil ifTrue: [^ self]] ! testResults ^ testResults! totalNumberOfTests ^ self testResults inject: 0 into: [:i :e | i + e numberOfTests]! wasFailure "Answer true if the receiver represents a successful test" ^ self wasSuccessful not! wasSuccessful "Answer true if the receiver represents a successful test" ^ (self testResults detect: [:each | each wasFailure] ifNone: [nil]) isNil! ! !TestResultCollection categoriesFor: #add:!adding! ! !TestResultCollection categoriesFor: #allErrors!accessing! ! !TestResultCollection categoriesFor: #allFailures!accessing! ! !TestResultCollection categoriesFor: #allOfType:!no category! ! !TestResultCollection categoriesFor: #failure!accessing! ! !TestResultCollection categoriesFor: #initialize!initializing! ! !TestResultCollection categoriesFor: #numberOfBadResults!no category! ! !TestResultCollection categoriesFor: #onItem:removedAtIndex:!no category! ! !TestResultCollection categoriesFor: #percentCorrect!accessing! ! !TestResultCollection categoriesFor: #percentFailed!accessing! ! !TestResultCollection categoriesFor: #removeFailureOrError:!no category! ! !TestResultCollection categoriesFor: #testResults!accessing! ! !TestResultCollection categoriesFor: #totalNumberOfTests!no category! ! !TestResultCollection categoriesFor: #wasFailure!no category! ! !TestResultCollection categoriesFor: #wasSuccessful!no category! ! !TestResultCollection class methodsFor! new ^ self basicNew initialize! publishedEventsOfInstances "Answer a Set of Symbols that describe the published events triggered by instances of the receiver." ^super publishedEventsOfInstances add: #resultsChanged; yourself! ! !TestResultCollection class categoriesFor: #new!instance creation! ! !TestResultCollection class categoriesFor: #publishedEventsOfInstances!no category! ! ExtendedListModel class instanceVariableNames: ''! ExtendedListModel comment: ''! !ExtendedListModel categoriesForClass!No category! ! !ExtendedListModel methodsFor! removeAtIndex: anInteger "Remove, and answer, the element of the receiver at the specified index, by shuffling elements which succeed it down one slot. Raise an BoundsError if there is no element with that index." | elem | elem := self list removeAtIndex: anInteger. self trigger: #itemRemovedAtIndex: with: anInteger. self trigger: #item:removedAtIndex: with: elem with: anInteger. ^elem! ! !ExtendedListModel categoriesFor: #removeAtIndex:!no category! ! !ExtendedListModel class methodsFor! publishedEventsOfInstances "Answer a Set of Symbols that describe the published events triggered by instances of the receiver." ^super publishedEventsOfInstances add: #item:removedAtIndex:; yourself! ! !ExtendedListModel class categoriesFor: #publishedEventsOfInstances!no category! ! TestSuiteModel class instanceVariableNames: ''! TestSuiteModel comment: ''! !TestSuiteModel categoriesForClass!No category! ! !TestSuiteModel methodsFor! allTestCaseClasses ^ TestSuite allTestCaseClasses ! filter: aCollection "Set the current filter which consists of a collection of packages. When asked for the current filtered set of test cases, only those cases belonging to the packages contained in the filter will be returned." filter := aCollection. self trigger: #filteredListChanged! filteredTestCaseClassList "Answer a collection of test case classes where each test case belongs to one of the packages contained in the filter collection." ^ (self allTestCaseClasses select: [:class | filter includes: class owningPackage]) asSortedCollection ! initialize filter := Array new.! percentage ^ self results isNil ifTrue: [''] ifFalse: [self results percentCorrect]! results ^ results! run: aCollection results := TestSuite runTestCases: aCollection. results when: #resultsChanged send: #triggerUpdates to: self. self triggerUpdates.! triggerUpdates self trigger: #percentageChanged; trigger: #resultsChanged ! wasFailure ^ self results wasFailure! wasSuccessful ^ self results wasSuccessful! ! !TestSuiteModel categoriesFor: #allTestCaseClasses!accessing! ! !TestSuiteModel categoriesFor: #filter:!no category! ! !TestSuiteModel categoriesFor: #filteredTestCaseClassList!no category! ! !TestSuiteModel categoriesFor: #initialize!no category! ! !TestSuiteModel categoriesFor: #percentage!accessing! ! !TestSuiteModel categoriesFor: #results!accessing! ! !TestSuiteModel categoriesFor: #run:!running! ! !TestSuiteModel categoriesFor: #triggerUpdates!no category! ! !TestSuiteModel categoriesFor: #wasFailure!testing! ! !TestSuiteModel categoriesFor: #wasSuccessful!testing! ! !TestSuiteModel class methodsFor! publishedEventsOfInstances "Answer a Set of Symbols that describe the published events triggered by instances of the receiver." ^super publishedEventsOfInstances add: #percentageChanged; add: #resultsChanged; add: #filteredListChanged; yourself! ! !TestSuiteModel class categoriesFor: #publishedEventsOfInstances!no category! ! TestResultsPresenter class instanceVariableNames: ''! TestResultsPresenter comment: ''! !TestResultsPresenter categoriesForClass!No category! ! !TestResultsPresenter methodsFor! createComponents super createComponents. failurePresenter := self add: ListPresenter new name: 'failures'. errorPresenter := self add: ListPresenter new name: 'errors'.! createSchematicWiring super createSchematicWiring. "Add additional stuff here if you want to respond to events from the various presenters." failurePresenter when: #actionPerformed send: #runSelected: to: self with: failurePresenter. errorPresenter when: #actionPerformed send: #runSelected: to: self with: errorPresenter! inspectError self inspectSelected: errorPresenter ! inspectFailure self inspectSelected: failurePresenter ! inspectSelected: aListPresenter aListPresenter selection inspect! model: aTestResultCollection super model: aTestResultCollection. aTestResultCollection isNil ifTrue: [^ self]. failurePresenter model: aTestResultCollection allFailures. errorPresenter model: aTestResultCollection allErrors.! removeSelectedFrom: aListPresenter aListPresenter model removeAtIndex: aListPresenter selectionByIndex ! runError self runSelected: errorPresenter; removeSelectedFrom: errorPresenter.! runFailure self runSelected: failurePresenter; removeSelectedFrom: failurePresenter! runSelected: aListPresenter aListPresenter selection run! ! !TestResultsPresenter categoriesFor: #createComponents!initializing! ! !TestResultsPresenter categoriesFor: #createSchematicWiring!initializing! ! !TestResultsPresenter categoriesFor: #inspectError!no category! ! !TestResultsPresenter categoriesFor: #inspectFailure!no category! ! !TestResultsPresenter categoriesFor: #inspectSelected:!no category! ! !TestResultsPresenter categoriesFor: #model:!accessing! ! !TestResultsPresenter categoriesFor: #removeSelectedFrom:!no category! ! !TestResultsPresenter categoriesFor: #runError!no category! ! !TestResultsPresenter categoriesFor: #runFailure!no category! ! !TestResultsPresenter categoriesFor: #runSelected:!no category! ! !TestResultsPresenter class methodsFor! defaultModel ^ TestResultCollection new! defaultView ^ 'DefaultView'! ! !TestResultsPresenter class categoriesFor: #defaultModel!models! ! !TestResultsPresenter class categoriesFor: #defaultView!no category! ! TestSuiteShell class instanceVariableNames: ''! TestSuiteShell comment: ''! !TestSuiteShell categoriesForClass!No category! ! !TestSuiteShell methodsFor! accelerators ^ AcceleratorTable fromStrings: #('Ctrl+S/accept' 'Ctrl+D/displayIt' 'Ctrl+E/evaluateIt' 'Ctrl+I/inspectIt')! accept "Saves the current method source. We only allow accept from the method browser card." self isMethodBrowserActive ifFalse: [^ nil]. methodBrowser saveCurrentMethod.! addAccelerators self view acceleratorTable: self accelerators! colorForPercentage ^ percentagePresenter value = 100.0 ifTrue: [Color black] ifFalse: [Color red].! createComponents super createComponents. testCasePresenter := self add: ListPresenter new name: 'testCases'. percentagePresenter := self add: NumberPresenter new name: 'percentage'. packagesPresenter := self add: PackageListPresenter new name: 'packages'. resultsPresenter := self add: TestResultsPresenter new name: 'testResults'. methodBrowser := self add: (MethodBrowser new filter: [:m | true]) name: 'methods'! createSchematicWiring super createSchematicWiring. "Add additional stuff here if you want to respond to events from the various presenters." self model when: #resultsChanged send: #updateResults to: self. self model when: #filteredListChanged send: #setVisibleTestCases to: self. percentagePresenter when: #valueChanged send: #updatePercentageColor to: self. testCasePresenter when: #selectionChanged send: #testCaseSelectionChanged to: self. packagesPresenter when: #selectionChanged send: #packageSelectionChanged to: self.! initialize super initialize. self packageManager when: #ownedChanged send: #onPackagesUpdated to: self; when: #loadedChanged send: #onPackagesUpdated to: self.! isMethodBrowserActive "Answer true if the method browser card is the currently visible card." | cardView methodsView | cardView := view viewNamed: 'cards'. methodsView := view viewNamed: 'methods'. ^ cardView currentCard == methodsView! isTestCaseSelected ^ testCasePresenter hasSelection! model: testSuiteModel super model: testSuiteModel. self setVisibleTestCases. percentagePresenter model: (testSuiteModel aspectValue: #percentage) aspectTriggersUpdates. resultsPresenter model: testSuiteModel results. packagesPresenter showAllPackages. ! onPackagesUpdated "Private - Set the receivers packagesModel to the current set of packages known by the PackageManager." | selected | selected := self selectedPackages. packagesPresenter showAllPackages. selected notNil ifTrue: [self selectedPackages: selected]. #todo. "Handle selection and related stuff."! onViewOpened super onViewOpened. self addAccelerators. ! package: aPackageOrNil "Set the selected package." packagesPresenter selection: aPackageOrNil ifAbsent: [] ! packageManager ^ PackageManager current! packageSelectionChanged self model filter: self selectedPackages! queryCommand: aCommandQuery super queryCommand: aCommandQuery. aCommandQuery command = #run ifTrue: [aCommandQuery enabled: self isTestCaseSelected]. aCommandQuery command == #accept ifTrue: [ aCommandQuery enabled: methodBrowser hasMethodSelected ]. ! run | selectedTestCases | selectedTestCases := testCasePresenter selectionIfNone: [nil]. model run: selectedTestCases. ! selectedPackages ^ packagesPresenter selectionOrNil! selectedPackages: aPackageCollectionOrNil "Set the selected package or packages." packagesPresenter selection: aPackageCollectionOrNil ifAbsent: [] ! selectedTestCaseMethods | methods | methods := OrderedCollection new. testCasePresenter selection do: [:each | methods addAll: each testCaseMethods]. ^ methods asArray! setVisibleTestCases testCasePresenter model: self model filteredTestCaseClassList asListModel.! testCaseSelectionChanged self updateMethodBrowser! updateMethodBrowser methodBrowser methodsList: self selectedTestCaseMethods.! updatePercentageColor percentagePresenter view backcolor: Color gray; forecolor: self colorForPercentage.! updateResults resultsPresenter model: self model results.! ! !TestSuiteShell categoriesFor: #accelerators!no category! ! !TestSuiteShell categoriesFor: #accept!commands! ! !TestSuiteShell categoriesFor: #addAccelerators!no category! ! !TestSuiteShell categoriesFor: #colorForPercentage!no category! ! !TestSuiteShell categoriesFor: #createComponents!initializing! ! !TestSuiteShell categoriesFor: #createSchematicWiring!initializing! ! !TestSuiteShell categoriesFor: #initialize!no category! ! !TestSuiteShell categoriesFor: #isMethodBrowserActive!testing! ! !TestSuiteShell categoriesFor: #isTestCaseSelected!testing! ! !TestSuiteShell categoriesFor: #model:!accessing! ! !TestSuiteShell categoriesFor: #onPackagesUpdated!event handling! ! !TestSuiteShell categoriesFor: #onViewOpened!event handling! ! !TestSuiteShell categoriesFor: #package:!accessing! ! !TestSuiteShell categoriesFor: #packageManager!no category! ! !TestSuiteShell categoriesFor: #packageSelectionChanged!event handling! ! !TestSuiteShell categoriesFor: #queryCommand:!commands! ! !TestSuiteShell categoriesFor: #run!commands! ! !TestSuiteShell categoriesFor: #selectedPackages!no category! ! !TestSuiteShell categoriesFor: #selectedPackages:!no category! ! !TestSuiteShell categoriesFor: #selectedTestCaseMethods!accessing! ! !TestSuiteShell categoriesFor: #setVisibleTestCases!no category! ! !TestSuiteShell categoriesFor: #testCaseSelectionChanged!event handling! ! !TestSuiteShell categoriesFor: #updateMethodBrowser!event handling! ! !TestSuiteShell categoriesFor: #updatePercentageColor!event handling! ! !TestSuiteShell categoriesFor: #updateResults!event handling! ! !TestSuiteShell class methodsFor! defaultModel ^ TestSuiteModel new! defaultView ^ 'Card View'! ! !TestSuiteShell class categoriesFor: #defaultModel!models! ! !TestSuiteShell class categoriesFor: #defaultView!no category! ! TestResultCollectionTestCase class instanceVariableNames: ''! TestResultCollectionTestCase comment: ''! !TestResultCollectionTestCase categoriesForClass!No category! ! !TestResultCollectionTestCase methodsFor! setUp testResultCollection := TestResultCollection new.! testAdd | theTest | theTest := TestSuite runNoErrorExample. testResultCollection add: theTest. self should: [testResultCollection testResults includes: theTest]! testCounts | theTest | theTest := TestSuite runNoErrorExample. testResultCollection add: TestSuite runNoErrorExample. self should: [testResultCollection numberOfBadResults = 0]. testResultCollection add: TestSuite runErrorExample. self should: [testResultCollection numberOfBadResults = 2].! testFailure testResultCollection add: TestSuite runErrorExample. self shouldnt: [testResultCollection wasSuccessful]. self should: [testResultCollection wasFailure]! testPercentageCorrect testResultCollection add: TestSuite runNoErrorExample. self should: [testResultCollection percentCorrect = 100.0]! testSuccess testResultCollection add: TestSuite runNoErrorExample. self shouldnt: [testResultCollection wasFailure]. self should: [testResultCollection wasSuccessful]! ! !TestResultCollectionTestCase categoriesFor: #setUp!set up! ! !TestResultCollectionTestCase categoriesFor: #testAdd!running!tests! ! !TestResultCollectionTestCase categoriesFor: #testCounts!running!tests! ! !TestResultCollectionTestCase categoriesFor: #testFailure!running!tests! ! !TestResultCollectionTestCase categoriesFor: #testPercentageCorrect!running!tests! ! !TestResultCollectionTestCase categoriesFor: #testSuccess!running!tests! ! !TestSuite class methodsFor! allTestCaseClasses ^ TestCase allSubclasses ! ! !TestSuite class categoriesFor: #allTestCaseClasses!accessing! ! !SequenceableCollection methodsFor! asExtendedListModel "Answer the receiver as a ExtendedListModel" ^ ExtendedListModel with: self! ! !SequenceableCollection categoriesFor: #asExtendedListModel!no category! ! !SequenceableCollection methodsFor! asListModel "Answer the receiver as a ListModel" ^ ListModel with: self! ! !SequenceableCollection categoriesFor: #asListModel!converting! ! !ListModel class methodsFor! emptyList "Answer a new instance of the receiver with an empty list" #addedByACS. ^ self with: OrderedCollection new! ! !ListModel class categoriesFor: #emptyList!instance creation! ! !TestResult methodsFor! errors ^ errors! ! !TestResult categoriesFor: #errors!accessing! ! !TestFailure methodsFor! exceptionDescription ^ exception description! ! !TestFailure categoriesFor: #exceptionDescription!no category! ! !TestResult methodsFor! failures ^ failures! ! !TestResult categoriesFor: #failures!accessing! ! !TestResult methodsFor! hasErrors ^ errors notEmpty ! ! !TestResult categoriesFor: #hasErrors!testing! ! !TestResult methodsFor! hasFailures ^ failures notEmpty! ! !TestResult categoriesFor: #hasFailures!testing! ! !TestResult methodsFor! numberOfErrors ^ errors size! ! !TestResult categoriesFor: #numberOfErrors!accessing! ! !TestResult methodsFor! numberOfFailures ^ failures size! ! !TestResult categoriesFor: #numberOfFailures!accessing! ! !TestCase class methodsFor! numberOfTestCaseSelectors ^ self testCaseSelectors size! ! !TestCase class categoriesFor: #numberOfTestCaseSelectors!no category! ! !TestResult methodsFor! numberOfTests ^ numberOfTests! ! !TestResult categoriesFor: #numberOfTests!accessing! ! !TestSuite methodsFor! numberOfTests ^ testCases size! ! !TestSuite categoriesFor: #numberOfTests!accessing! ! !TestResult methodsFor! removeFailureOrError: aTestFailure "Remove aTestFailure from either the errors or failures collection. If not found in either collection, answer nil." (errors remove: aTestFailure ifAbsent: [nil]) notNil ifTrue: [^ self]. failures remove: aTestFailure ifAbsent: [^ nil].! ! !TestResult categoriesFor: #removeFailureOrError:!no category! ! !TestFailure methodsFor! run testCase run! ! !TestFailure categoriesFor: #run!no category! ! !TestSuite class methodsFor! runAllTestCases " TestSuite runAllTestCases " ^ self runTestCases: self allTestCaseClasses! ! !TestSuite class categoriesFor: #runAllTestCases!running! ! !TestSuite class methodsFor! runTestCases: aCollection " TestSuite runTestCases: TestSuite allTestCaseClasses " | results | aCollection isNil ifTrue: [^ nil]. results := TestResultCollection new. aCollection do: [:testCaseClass | results add: (self testCasesFor: testCaseClass) run]. ^ results ! ! !TestSuite class categoriesFor: #runTestCases:!running! ! !TestSuite class methodsFor! runTestCasesFor: aClass "Run the test cases defined for the given class. Test cases are assumed to reside under the name TestCase. So, for the class Set, there should be a corresponding SetTestCase class containing test cases for Set. TestSuite runTestCasesFor: Set " | testCaseClass | testCaseClass := Smalltalk at: aClass testCaseName ifAbsent: [^ self error: ('No test case class exists for ' , aClass name)]. ^ self runTestCases: (OrderedCollection with: testCaseClass)! ! !TestSuite class categoriesFor: #runTestCasesFor:!running! ! !MethodBrowser methodsFor! saveCurrentMethod "Save and answer the compiled method associated with the currently selected method. If none exists, answer nil." | method | #addedByACS. (method := self method) isNil ifTrue: [^ nil]. ^ self saveMethodInClass: method methodClass! ! !MethodBrowser categoriesFor: #saveCurrentMethod!no category! ! !TestFailure methodsFor! selector ^ testCase selector! ! !TestFailure categoriesFor: #selector!accessing! ! !TestCase methodsFor! selector ^ selector! ! !TestCase categoriesFor: #selector!accessing! ! !TestResult methodsFor! setTest: aTestSuite testName := aTestSuite name. failures := OrderedCollection new. errors := OrderedCollection new. numberOfTests := aTestSuite numberOfTests! ! !TestResult categoriesFor: #setTest:!private! ! !TestCase class methodsFor! testCaseMethods "Answer a collection of test case methods, i.e. those found in the running category." ^ (self selectorsInCategory: 'running') collect: [:each | self compiledMethodAt: each]! ! !TestCase class categoriesFor: #testCaseMethods!no category! ! !Class methodsFor! testCaseName "Answer the name of the test case which would be appropriate for the receiver." #addedByACS. ^ name , 'TestCase'! ! !Class categoriesFor: #testCaseName!no category! ! !TestCase methodsFor! testCaseName "Answer the name of the test case." ^ self class name! ! !TestCase categoriesFor: #testCaseName!accessing! ! !TestFailure methodsFor! testCaseName ^ testCase testCaseName! ! !TestFailure categoriesFor: #testCaseName!no category! ! !TestCase class methodsFor! testCases "Answer a collection of test cases based on the methods found in the running category." ^ self testCaseSelectors collect:[:each | self selector: each]! ! !TestCase class categoriesFor: #testCases!instance creation! ! !TestCase class methodsFor! testCaseSelectors "Answer a collection of test case methods, i.e. those found in the running category." ^ self selectorsInCategory: 'running'! ! !TestCase class categoriesFor: #testCaseSelectors!no category! ! !TestSuite class methodsFor! testCasesFor: aTestCaseClass "Run all test cases defined for aTestCaseClass" | test | test := self named: (aTestCaseClass name , ' Test Case'). test addTestCases: aTestCaseClass testCases. ^ test! ! !TestSuite class categoriesFor: #testCasesFor:!private! ! !TestFailure methodsFor! testMethod ^ testCase testMethod! ! !TestFailure categoriesFor: #testMethod!no category! ! !TestCase class methodsFor! value: anObject "Answer the text to be displayed in a list for the receiver." | suffix count | suffix := (count := anObject numberOfTestCaseSelectors) = 1 ifTrue: [' test method)'] ifFalse: [' test methods)']. ^ anObject displayString , ' (' , count printString , suffix! ! !TestCase class categoriesFor: #value:!no category! ! !TestResult methodsFor! wasFailure ^ self wasSuccessful not ! ! !TestResult categoriesFor: #wasFailure!testing! !