[squeak-dev] The Inbox: SUnitGUI-ct.92.mczcommits at source.squeak.org commits at source.squeak.orgThu Jul 14 14:11:26 UTC 2022
A new version of SUnitGUI was added to project The Inbox: http://source.squeak.org/inbox/SUnitGUI-ct.92.mcz ==================== Summary ==================== Name: SUnitGUI-ct.92 Author: ct Time: 8 June 2022, 4:45:47.033837 pm UUID: 860f8009-e951-3b4d-bdc6-4968e88dc980 Ancestors: SUnitGUI-mt.91 Avoids redundant information ('No methods found for coverage analysis.') when canceling the package selection dialog in the TestRunner after pressing "Run Coverage". Also improves multilingual support and migrates to new UIManager entrypoint. =============== Diff against SUnitGUI-mt.91 =============== Item was removed: - SystemOrganization addCategory: #SUnitGUI! Item was removed: - ----- Method: TestCase class>>packageNamesUnderTest (in category '*sunitgui') ----- - packageNamesUnderTest - "Answer a collection of package names under test. This is used by the test runner to automatically instrument the code in these packages when checking for test coverage." - - ^ #()! Item was removed: - ProtoObject subclass: #TestCoverage - instanceVariableNames: 'hasRun reference method' - classVariableNames: '' - poolDictionaries: '' - category: 'SUnitGUI'! Item was removed: - ----- Method: TestCoverage class>>on: (in category 'instance creation') ----- - on: aMethodReference - ^ self new initializeOn: aMethodReference! Item was removed: - ----- Method: TestCoverage>>doesNotUnderstand: (in category 'private') ----- - doesNotUnderstand: aMessage - ^ method perform: aMessage selector withArguments: aMessage arguments! Item was removed: - ----- Method: TestCoverage>>flushCache (in category 'private') ----- - flushCache! Item was removed: - ----- Method: TestCoverage>>hasRun (in category 'testing') ----- - hasRun - ^ hasRun! Item was removed: - ----- Method: TestCoverage>>initializeOn: (in category 'initialization') ----- - initializeOn: aMethodReference - hasRun := false. - reference := aMethodReference. - method := reference compiledMethod! Item was removed: - ----- Method: TestCoverage>>install (in category 'actions') ----- - install - reference actualClass methodDictionary - at: reference methodSymbol - put: self! Item was removed: - ----- Method: TestCoverage>>mark (in category 'private') ----- - mark - hasRun := true! Item was removed: - ----- Method: TestCoverage>>reference (in category 'private') ----- - reference - ^ reference! Item was removed: - ----- Method: TestCoverage>>run:with:in: (in category 'evaluation') ----- - run: aSelector with: anArray in: aReceiver - self mark; uninstall. - ^ aReceiver withArgs: anArray executeMethod: method! Item was removed: - ----- Method: TestCoverage>>uninstall (in category 'actions') ----- - uninstall - reference actualClass methodDictionary - at: reference methodSymbol - put: method! Item was removed: - Model subclass: #TestRunner - instanceVariableNames: 'categories categoryIndex categoriesSelected classes classIndex classesSelected failedList failedSelected errorList errorSelected lastUpdate result previousRun categoryPattern classPattern environment' - classVariableNames: '' - poolDictionaries: '' - category: 'SUnitGUI'! - - !TestRunner commentStamp: '<historical>' prior: 0! - <lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'> - - ! Item was removed: - ----- Method: TestRunner class>>build (in category 'instance-creation') ----- - build - ^ ToolBuilder build: self new.! Item was removed: - ----- Method: TestRunner class>>buildForSuite: (in category 'instance-creation') ----- - buildForSuite: aTestSuite - ^ ToolBuilder build: (self newForSuite: aTestSuite).! Item was removed: - ----- Method: TestRunner class>>initialize (in category 'initialization') ----- - initialize - self registerInWorldMenu; registerInToolsFlap.! Item was removed: - ----- Method: TestRunner class>>newForSuite: (in category 'instance-creation') ----- - newForSuite: aSuite - - | runner classes categories | - runner := TestRunner new. - classes := aSuite tests asSet collect: #class. - categories := classes collect: #category. - ^ runner - filterCategoriesBy: ((categories collect: #asString) asArray joinSeparatedBy: $;); - filterClassesBy: ((classes collect: #asString) asArray joinSeparatedBy: $;); - yourself! Item was removed: - ----- Method: TestRunner class>>open (in category 'instance-creation') ----- - open - ^ ToolBuilder open: self new.! Item was removed: - ----- Method: TestRunner class>>openForSuite: (in category 'instance-creation') ----- - openForSuite: aTestSuite - ^ ToolBuilder open: (self newForSuite: aTestSuite).! Item was removed: - ----- Method: TestRunner class>>registerInToolsFlap (in category 'initialization') ----- - registerInToolsFlap - self environment at: #Flaps ifPresent: [ :class | - class - registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools'; - replaceToolsFlap ].! Item was removed: - ----- Method: TestRunner class>>registerInWorldMenu (in category 'initialization') ----- - registerInWorldMenu - self environment at: #TheWorldMenu ifPresent: [ :class | - class registerOpenCommand: (Array - with: 'Test Runner' - with: (Array - with: self - with: #open)) ].! Item was removed: - ----- Method: TestRunner class>>themeProperties (in category 'preferences') ----- - themeProperties - - ^ super themeProperties, { - { #failureColor. 'Colors'. 'Color to indicate failed tests.'}. - { #errorColor. 'Colors'. 'Color to indicate errored tests.'}. - { #passColor. 'Colors'. 'Color to indicate passed tests.'}. - - { #failureTextColor. 'Colors'. 'Color to indicate failed tests.'}. - { #errorTextColor. 'Colors'. 'Color to indicate errored tests.'}. - { #passTextColor. 'Colors'. 'Color to indicate passed tests.'}. - - }! Item was removed: - ----- Method: TestRunner>>addDeclaredPackagesUnderTestTo: (in category 'actions') ----- - addDeclaredPackagesUnderTestTo: packages - classesSelected do: - [ :class | - (class class includesSelector: #packageNamesUnderTest) ifTrue: - [ class packageNamesUnderTest do: [ :name | packages add: (PackageInfo named: name) ] ] ]! Item was removed: - ----- Method: TestRunner>>addMethodsUnderTestIn:to: (in category 'actions') ----- - addMethodsUnderTestIn: packages to: methods - packages - do: [:package | package isNil - ifFalse: [package methods - do: [:method | ((#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method methodSymbol) - or: [method compiledMethod isAbstract - or: [method compiledMethod hasLiteral: #ignoreForCoverage]]) - ifFalse: [methods add: method]]]]! Item was removed: - ----- Method: TestRunner>>applyUserInterfaceTheme (in category 'updating') ----- - applyUserInterfaceTheme - - super applyUserInterfaceTheme. - - self changed: #statusColor. - self changed: #statusTextColor.! Item was removed: - ----- Method: TestRunner>>baseClass (in category 'accessing') ----- - baseClass - ^ TestCase! Item was removed: - ----- Method: TestRunner>>basicRunSuite:do: (in category 'processing') ----- - basicRunSuite: aTestSuite do: aBlock - self basicSetUpSuite: aTestSuite. - [ | prefix | - prefix := aTestSuite name isEmptyOrNil - ifTrue: [ '' ] - ifFalse: [ aTestSuite name , ' - ' ]. - aTestSuite tests size = 1 - ifTrue: [ aTestSuite tests do: aBlock ] - ifFalse: - [ aTestSuite tests - do: aBlock - displayingProgress: [ : test | prefix , test printString ] - every: 0 ] ] ensure: [ self basicTearDownSuite: aTestSuite ]! Item was removed: - ----- Method: TestRunner>>basicSetUpSuite: (in category 'processing') ----- - basicSetUpSuite: aTestSuite - aTestSuite resources do: [ :each | - each isAvailable - ifFalse: [ each signalInitializationError ] ].! Item was removed: - ----- Method: TestRunner>>basicTearDownSuite: (in category 'processing') ----- - basicTearDownSuite: aTestSuite - aTestSuite resources do: [ :each | each reset ].! Item was removed: - ----- Method: TestRunner>>browseClass (in category 'accessing-classes') ----- - browseClass - (classes at: classIndex ifAbsent: [ ^ self ]) browse! Item was removed: - ----- Method: TestRunner>>browserEnvironment (in category 'private') ----- - browserEnvironment - ^ Smalltalk classNamed: #BrowserEnvironment.! Item was removed: - ----- Method: TestRunner>>buildButtonsWith: (in category 'building') ----- - buildButtonsWith: aBuilder - ^ aBuilder pluggablePanelSpec new - model: self; - layout: #horizontal; - children: (self buttons collect: [ :each | - aBuilder pluggableButtonSpec new - model: self; - label: each first; - action: each second; - enabled: each third; - yourself ]); - yourself.! Item was removed: - ----- Method: TestRunner>>buildCategoriesWith: (in category 'building') ----- - buildCategoriesWith: aBuilder - ^ aBuilder pluggableMultiSelectionListSpec new - model: self; - list: #categoryList; - menu: #categoryMenu:; - getIndex: #categorySelected; - setIndex: #categorySelected:; - getSelectionList: #categoryAt:; - setSelectionList: #categoryAt:put:; - yourself.! Item was removed: - ----- Method: TestRunner>>buildClassesWith: (in category 'building') ----- - buildClassesWith: aBuilder - ^ aBuilder pluggableMultiSelectionListSpec new - model: self; - list: #classList; - menu: #classMenu:; - getIndex: #classSelected; - setIndex: #classSelected:; - getSelectionList: #classAt:; - setSelectionList: #classAt:put:; - yourself.! Item was removed: - ----- Method: TestRunner>>buildErrorListWith: (in category 'building') ----- - buildErrorListWith: aBuilder - ^ aBuilder pluggableListSpec new - model: self; - name: #errorList; - help: 'Errors' translated; - list: #errorList; - menu: #errorMenu:; - getIndex: #errorSelected; - setIndex: #errorSelected:; - yourself.! Item was removed: - ----- Method: TestRunner>>buildFailureListWith: (in category 'building') ----- - buildFailureListWith: aBuilder - ^ aBuilder pluggableListSpec new - model: self; - name: #failureList; - help: 'Failures' translated; - list: #failedList; - menu: #failureMenu:; - getIndex: #failedSelected; - setIndex: #failedSelected:; - yourself.! Item was removed: - ----- Method: TestRunner>>buildStatusWith: (in category 'building') ----- - buildStatusWith: aBuilder - ^ aBuilder pluggableTextSpec new - model: self; - menu: #statusMenu:; - color: #statusColor; - textColor: #statusTextColor; - getText: #statusText; - yourself.! Item was removed: - ----- Method: TestRunner>>buildWith: (in category 'building') ----- - buildWith: aBuilder - | window | - window := aBuilder pluggableWindowSpec new - model: self; label: self label; extent: self extent; - children: (OrderedCollection new - add: ((self buildCategoriesWith: aBuilder) - frame: self categoriesFrame; - yourself); - add: ((self buildClassesWith: aBuilder) - frame: self classesFrame; - yourself); - add: ((self buildStatusWith: aBuilder) - frame: self statusFrame; - yourself); - add: ((self buildFailureListWith: aBuilder) - frame: self failureListFrame; - yourself); - add: ((self buildErrorListWith: aBuilder) - frame: self errorListFrame; - yourself); - add: ((self buildButtonsWith: aBuilder) - frame: self buttonsFrame; - yourself); - yourself); - yourself. - ^ aBuilder build: window.! Item was removed: - ----- Method: TestRunner>>buttonHeight (in category 'building') ----- - buttonHeight - ^ Preferences standardButtonFont height * 3! Item was removed: - ----- Method: TestRunner>>buttons (in category 'accessing-ui') ----- - buttons - ^ #(( 'Run Selected' #runAll #hasRunnable ) - ( 'Run Profiled' #runProfiled #hasRunnable ) - ( 'Run Coverage' #runCoverage #hasRunnable ) - ( 'Run Failures' #runFailures #hasFailures ) - ( 'Run Errors' #runErrors #hasErrors ))! Item was removed: - ----- Method: TestRunner>>buttonsFrame (in category 'building') ----- - buttonsFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 1 offset: self buttonHeight negated; - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: 0! Item was removed: - ----- Method: TestRunner>>categoriesFrame (in category 'building') ----- - categoriesFrame - ^LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 0.25 offset: 0; - bottomFraction: 1 offset: self buttonHeight negated! Item was removed: - ----- Method: TestRunner>>categoryAt: (in category 'accessing-categories') ----- - categoryAt: anIndex - ^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).! Item was removed: - ----- Method: TestRunner>>categoryAt:put: (in category 'accessing-categories') ----- - categoryAt: anInteger put: aBoolean - categoriesSelected := categoriesSelected - perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) - with: (categories at: anInteger ifAbsent: [ ^ self ]). - self - changed: #categoryAt:; - changed: #categorySelected; - updateClasses.! Item was removed: - ----- Method: TestRunner>>categoryList (in category 'accessing-categories') ----- - categoryList - ^ categories! Item was removed: - ----- Method: TestRunner>>categoryMenu: (in category 'accessing-categories') ----- - categoryMenu: aMenu - ^ aMenu - title: 'Categories'; - add: 'Select all' action: #selectAllCategories; - add: 'Select inversion' action: #selectInverseCategories; - add: 'Select none' action: #selectNoCategories; - addLine; - add: 'Filter...' action: #filterCategories; - addLine; - add: 'Refresh' action: #updateCategories; - add: 'Sort' action: #sortCategories; - yourself.! Item was removed: - ----- Method: TestRunner>>categorySelected (in category 'accessing-categories') ----- - categorySelected - ^ categoryIndex ifNil: [0]! Item was removed: - ----- Method: TestRunner>>categorySelected: (in category 'accessing-categories') ----- - categorySelected: anInteger - categoryIndex := anInteger. - self changed: #categorySelected.! Item was removed: - ----- Method: TestRunner>>classAt: (in category 'accessing-classes') ----- - classAt: anInteger - ^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! Item was removed: - ----- Method: TestRunner>>classAt:put: (in category 'accessing-classes') ----- - classAt: anInteger put: aBoolean - classesSelected := classesSelected - perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) - with: (classes at: anInteger ifAbsent: [ ^ self ]). - self - changed: #classAt:; - changed: #classSelected; - changed: #hasRunnable.! Item was removed: - ----- Method: TestRunner>>classList (in category 'accessing-classes') ----- - classList - - | helper | - classes isEmpty ifTrue: [ ^ classes ]. - - helper := Browser new. - ^ helper - flattenHierarchyTree: (helper createHierarchyTreeOf: classes) - on: OrderedCollection new - indent: '' - by: ' ' - format: [:class | class isAbstract - ifTrue: [class name asText addAttribute: TextEmphasis italic; yourself] - ifFalse: [ - (class history notNil and: [class history includesKey: #duration]) - ifFalse: ['{1} ({2} tests)' format: { - class name. - (class shouldInheritSelectors - ifTrue: [class allTestSelectors] - ifFalse: [class testSelectors]) size}] - ifTrue: [ - | duration | - duration := (class history at: #duration). - '{1} ({2} tests, {3})' format: { - class name. - (class shouldInheritSelectors - ifTrue: [class allTestSelectors] - ifFalse: [class testSelectors]) size. - duration = 0 ifTrue: ['< 1 ms'] ifFalse: [ - duration < 1000 ifTrue: [duration asString, ' ms'] ifFalse: [ - (duration / 1000) rounded asString, ' secs']]}]]] ! Item was removed: - ----- Method: TestRunner>>classMenu: (in category 'accessing-classes') ----- - classMenu: aMenu - ^ aMenu - title: 'Classes'; - add: 'Browse' action: #browseClass; - addLine; - add: 'Select all' action: #selectAllClasses; - add: 'Select subclasses' action: #selectSubclasses; - add: 'Select inversion' action: #selectInverseClasses; - add: 'Select none' action: #selectNoClasses; - addLine; - add: 'Select failures' action: #selectClassesWithFailures; - add: 'Select errors' action: #selectClassesWithErrors; - add: 'Select failures & errors' action: #selectClassesWithDefects; - addLine; - add: 'Filter...' action: #filterClasses; - addLine; - add: 'Refresh' action: #updateClasses; - yourself.! Item was removed: - ----- Method: TestRunner>>classSelected (in category 'accessing-classes') ----- - classSelected - ^ classIndex! Item was removed: - ----- Method: TestRunner>>classSelected: (in category 'accessing-classes') ----- - classSelected: anInteger - classIndex := anInteger. - self changed: #classSelected! Item was removed: - ----- Method: TestRunner>>classesFrame (in category 'building') ----- - classesFrame - ^LayoutFrame new - leftFraction: 0.25 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 0.5 offset: 0; - bottomFraction: 1 offset: self buttonHeight negated! Item was removed: - ----- Method: TestRunner>>classesSelected (in category 'accessing') ----- - classesSelected - ^ classesSelected! Item was removed: - ----- Method: TestRunner>>collectCoverageFor: (in category 'actions') ----- - collectCoverageFor: methods - | wrappers suite | - wrappers := methods collect: [ :each | TestCoverage on: each ]. - suite := self - reset; - suiteAll. - - [ wrappers do: [ :each | each install ]. - [ self runSuite: suite ] ensure: [ wrappers do: [ :each | each uninstall ] ] ] valueUnpreemptively. - wrappers := wrappers reject: [ :each | each hasRun ]. - wrappers isEmpty - ifTrue: - [ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ] - ifFalse: - [ ToolSet - browseMessageSet: (wrappers collect: [ :each | each reference ]) - name: 'Not Covered Code (' , (100 - (100 * wrappers size // methods size)) printString , '% Code Coverage)' - autoSelect: nil ]. - self saveResultInHistory! Item was removed: - ----- Method: TestRunner>>debug: (in category 'actions') ----- - debug: aTestCase - self debugSuite: (TestSuite new - addTest: aTestCase; - yourself).! Item was removed: - ----- Method: TestRunner>>debugSuite: (in category 'actions') ----- - debugSuite: aTestSuite - self basicRunSuite: aTestSuite do: [ :each | each debug ].! Item was removed: - ----- Method: TestRunner>>defaultWindowColor (in category 'user interface') ----- - defaultWindowColor - ^ (Color r: 0.9 g: 0.576 b: 0.09)! Item was removed: - ----- Method: TestRunner>>environment (in category 'accessing') ----- - environment - ^ environment ifNil: [Smalltalk globals]! Item was removed: - ----- Method: TestRunner>>environment: (in category 'accessing') ----- - environment: anEnvironment - environment := anEnvironment. - self update; reset! Item was removed: - ----- Method: TestRunner>>errorList (in category 'accessing-testing') ----- - errorList - ^ errorList collect: [ :each | each printString ].! Item was removed: - ----- Method: TestRunner>>errorListFrame (in category 'building') ----- - errorListFrame - ^LayoutFrame new - leftFraction: 0.5 offset: 0; - topFraction: 0.5 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: self buttonHeight negated! Item was removed: - ----- Method: TestRunner>>errorMenu: (in category 'accessing-menu') ----- - errorMenu: aMenu - ^ self statusMenu: aMenu! Item was removed: - ----- Method: TestRunner>>errorSelected (in category 'accessing-testing') ----- - errorSelected - ^ errorList indexOf: errorSelected.! Item was removed: - ----- Method: TestRunner>>errorSelected: (in category 'accessing-testing') ----- - errorSelected: anInteger - errorSelected := errorList at: anInteger ifAbsent: nil. - self changed: #errorSelected. - errorSelected ifNotNil: [ self debug: errorSelected ].! Item was removed: - ----- Method: TestRunner>>excludeClassesNotUnderTestFrom: (in category 'actions') ----- - excludeClassesNotUnderTestFrom: methods - - classesSelected do: - [ :class | - (class class includesSelector: #classNamesNotUnderTest) ifTrue: - [ class classNamesNotUnderTest do: - [ :className | | theClass | - theClass := Smalltalk classNamed: className. - theClass ifNotNil:[ - theClass methods do: - [ :each | - methods - remove: each methodReference - ifAbsent: [ ] ]. - theClass class methods do: - [ :each | - methods - remove: each methodReference - ifAbsent: [ ] ]] ] ] ]! Item was removed: - ----- Method: TestRunner>>extent (in category 'accessing-ui') ----- - extent - ^ 640 @ 480! Item was removed: - ----- Method: TestRunner>>failedList (in category 'accessing-testing') ----- - failedList - ^ failedList collect: [ :each | each printString ].! Item was removed: - ----- Method: TestRunner>>failedSelected (in category 'accessing-testing') ----- - failedSelected - ^ failedList indexOf: failedSelected.! Item was removed: - ----- Method: TestRunner>>failedSelected: (in category 'accessing-testing') ----- - failedSelected: anInteger - failedSelected := failedList at: anInteger ifAbsent: nil. - self changed: #failedSelected. - failedSelected ifNotNil: [ self debug: failedSelected ].! Item was removed: - ----- Method: TestRunner>>failureListFrame (in category 'building') ----- - failureListFrame - ^LayoutFrame new - leftFraction: 0.5 offset: 0; - topFraction: 0 offset: self statusHeight; - rightFraction: 1 offset: 0; - bottomFraction: 0.5 offset: 0! Item was removed: - ----- Method: TestRunner>>failureMenu: (in category 'accessing-menu') ----- - failureMenu: aMenu - ^ aMenu - add: 'Profile this test' action: #runProfileOnFailure; - yourself! Item was removed: - ----- Method: TestRunner>>filterCategories (in category 'accessing-categories') ----- - filterCategories - | pattern | - pattern := UIManager default - request: 'Pattern(s) to select categories:\ (separate patterns with '';'')' withCRs - initialAnswer: (categoryPattern ifNil: ['*']). - (pattern isNil or: [pattern isEmpty]) ifTrue: - [^self]. - self filterCategoriesBy: pattern! Item was removed: - ----- Method: TestRunner>>filterCategoriesBy: (in category 'accessing-categories') ----- - filterCategoriesBy: aPattern - categoriesSelected := ((categoryPattern := aPattern) subStrings: ';') - inject: Set new - into: [:matches :subPattern| - matches - addAll: (categories select: [ :each | subPattern match: each]); - yourself]. - self changed: #allSelections; changed: #categorySelected; updateClasses! Item was removed: - ----- Method: TestRunner>>filterClasses (in category 'accessing-classes') ----- - filterClasses - | pattern | - pattern := UIManager default - request: 'Pattern(s) to select tests:\ (separate patterns with '';'')' withCRs - initialAnswer: (classPattern ifNil: '*'). - (pattern isNil or: [pattern isEmpty]) ifTrue: - [^self]. - self filterClassesBy: pattern! Item was removed: - ----- Method: TestRunner>>filterClassesBy: (in category 'accessing-classes') ----- - filterClassesBy: aPattern - classesSelected := ((classPattern := aPattern) subStrings: ';') - inject: Set new - into: [:matches :subPattern| - matches - addAll: (classes select: [ :each | subPattern match: each name]); - yourself]. - self - changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>findCategories (in category 'utilities') ----- - findCategories - | visible | - visible := Set new. - self baseClass withAllSubclassesDo: [ :each | - each category ifNotNil: [ :category | - visible add: category ] ]. - ^ Array streamContents: [ :stream | - self environment organization categories do: [ :each | - (visible includes: each) - ifTrue: [ stream nextPut: each ] ] ].! Item was removed: - ----- Method: TestRunner>>findClassesForCategories: (in category 'utilities') ----- - findClassesForCategories: aCollection - - | environment items | - aCollection isEmpty - ifTrue: [ ^ self baseClass withAllSubclasses asSet ]. - environment := self environment. - items := aCollection gather: [ :category | - ((environment organization listAtCategoryNamed: category) - collect: [ :each | environment valueOf: each ]) - select: [ :each | each includesBehavior: self baseClass ] ]. - ^ items asSet.! Item was removed: - ----- Method: TestRunner>>hasErrors (in category 'testing') ----- - hasErrors - ^ result hasErrors.! Item was removed: - ----- Method: TestRunner>>hasFailures (in category 'testing') ----- - hasFailures - ^ result hasFailures.! Item was removed: - ----- Method: TestRunner>>hasHistory (in category 'history saving') ----- - hasHistory - - self flag: #Useless. "No Senders?" - ^ true! Item was removed: - ----- Method: TestRunner>>hasProgress (in category 'history saving') ----- - hasProgress - - result classesTested do: [:cls | - (cls class methodDictionary includesKey: #lastStoredRun) - ifTrue: [^ true]]. - ^ false! Item was removed: - ----- Method: TestRunner>>hasResults (in category 'history saving') ----- - hasResults - - ^ result notNil! Item was removed: - ----- Method: TestRunner>>hasRunnable (in category 'testing') ----- - hasRunnable - ^ classesSelected notEmpty.! Item was removed: - ----- Method: TestRunner>>historyMenuList (in category 'history saving') ----- - historyMenuList - ^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])! Item was removed: - ----- Method: TestRunner>>initialize (in category 'initialization') ----- - initialize - super initialize. - failedList := errorList := Array new. - SystemChangeNotifier uniqueInstance - notify: self ofSystemChangesOfItem: #class change: #Added using: #update; - notify: self ofSystemChangesOfItem: #category change: #Added using: #update; - notify: self ofSystemChangesOfItem: #class change: #Removed using: #update; - notify: self ofSystemChangesOfItem: #category change: #Removed using: #update; - notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update; - notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update; - notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update; - notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update; - notify: self ofSystemChangesOfItem: #method change: #Removed using: #updateMethods. - environment := Environment current. - self update; reset! Item was removed: - ----- Method: TestRunner>>label (in category 'accessing-ui') ----- - label - ^ 'Test Runner in environment ', environment name! Item was removed: - ----- Method: TestRunner>>label:forSuite: (in category 'private') ----- - label: aString forSuite: aTestSuite - ^ String streamContents: [ :stream | - stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString. - aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! Item was removed: - ----- Method: TestRunner>>postAcceptBrowseFor: (in category 'accessing-ui') ----- - postAcceptBrowseFor: aModel - "Nothing to do."! Item was removed: - ----- Method: TestRunner>>previousRun (in category 'history saving') ----- - previousRun - - ^ previousRun ifNil: [ previousRun := OrderedCollection new ]! Item was removed: - ----- Method: TestRunner>>promptForPackages (in category 'actions') ----- - promptForPackages - | packages | - packages := (PackageOrganizer default packages - reject: [:package | (package packageName beginsWith: 'Kernel') - or: [(package packageName beginsWith: 'Collections') - or: [(package packageName beginsWith: 'Exceptions') - or: [(package packageName beginsWith: 'SUnit') - or: [(package packageName beginsWith: 'System') - or: [package packageName includesSubstring: 'Test' caseSensitive: false]]]]]]) - sort: [:a :b | a packageName < b packageName]. - packages := Array - with: (UIManager default - chooseFrom: (packages - collect: [:package | package packageName]) - values: packages - title: 'Select Package'). - ^ packages! Item was removed: - ----- Method: TestRunner>>representsSameBrowseeAs: (in category 'accessing-ui') ----- - representsSameBrowseeAs: anotherModel - ^ self class = anotherModel class - and: [ classesSelected = anotherModel classesSelected ]! Item was removed: - ----- Method: TestRunner>>reset (in category 'actions') ----- - reset - self result: TestResult new; updateResults.! Item was removed: - ----- Method: TestRunner>>result (in category 'accessing-testing') ----- - result - ^ result! Item was removed: - ----- Method: TestRunner>>result: (in category 'accessing-testing') ----- - result: aResult - result := aResult! Item was removed: - ----- Method: TestRunner>>runAll (in category 'actions') ----- - runAll - self reset; runSuite: self suiteAll. - self saveResultInHistory! Item was removed: - ----- Method: TestRunner>>runCoverage (in category 'actions') ----- - runCoverage - | packages methods | - packages := Set new. - self addDeclaredPackagesUnderTestTo: packages. - packages isEmpty ifTrue: - [ packages := self promptForPackages ]. - methods := OrderedCollection new. - self - addMethodsUnderTestIn: packages - to: methods. - self excludeClassesNotUnderTestFrom: methods. - methods isEmpty ifTrue: - [ ^ UIManager default inform: 'No methods found for coverage analysis.' ]. - self collectCoverageFor: methods - ! Item was removed: - ----- Method: TestRunner>>runErrors (in category 'actions') ----- - runErrors - self result resetErrors. - self runSuite: self suiteErrors.! Item was removed: - ----- Method: TestRunner>>runFailures (in category 'actions') ----- - runFailures - self result resetFailures. - self runSuite: self suiteFailures.! Item was removed: - ----- Method: TestRunner>>runProfileOnFailure (in category 'actions') ----- - runProfileOnFailure - "if we have selected a failure case, run it within a MessageTAlly and see what is taking time" - - failedSelected ifNotNil: [self - basicRunSuite: (TestSuite new addTest: failedSelected; - yourself) - do: [:each | MessageTally - spyOn: [self runTest: each]]]! Item was removed: - ----- Method: TestRunner>>runProfiled (in category 'actions') ----- - runProfiled - MessageTally spyOn: [ self runAll ].! Item was removed: - ----- Method: TestRunner>>runSuite: (in category 'actions') ----- - runSuite: aTestSuite - self basicRunSuite: aTestSuite do: [ :each | self runTest: each ]. - self updateResults - - ! Item was removed: - ----- Method: TestRunner>>runTest: (in category 'actions') ----- - runTest: aTestCase - aTestCase run: result. - self updateStatus: true.! Item was removed: - ----- Method: TestRunner>>saveResultInHistory (in category 'history saving') ----- - saveResultInHistory - result dispatchResultsIntoHistory. - self changed: #classList.! Item was removed: - ----- Method: TestRunner>>selectAllCategories (in category 'accessing-categories') ----- - selectAllCategories - categoriesSelected := categories asSet. - self changed: #allSelections; changed: #categorySelected; updateClasses! Item was removed: - ----- Method: TestRunner>>selectAllClasses (in category 'accessing-classes') ----- - selectAllClasses - "Fixed to update all selections now that the - selection invalidation has been optimised." - - classesSelected := classes asSet. - self - changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectClassesWithDefects (in category 'accessing-classes') ----- - selectClassesWithDefects - "Use test history to select classes that previously did not fully pass." - - classesSelected := classes select: [:class | class hasDefects]. - self changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectClassesWithErrors (in category 'accessing-classes') ----- - selectClassesWithErrors - "Use test history to select classes that raised errors." - - classesSelected := classes select: [:class | class hasErrors]. - self changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectClassesWithFailures (in category 'accessing-classes') ----- - selectClassesWithFailures - "Use test history to select classes that failed." - - classesSelected := classes select: [:class | class hasFailures]. - self changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectInverseCategories (in category 'accessing-categories') ----- - selectInverseCategories - categoriesSelected := categories asSet - removeAll: categoriesSelected; - yourself. - self changed: #allSelections; changed: #categorySelected; updateClasses! Item was removed: - ----- Method: TestRunner>>selectInverseClasses (in category 'accessing-classes') ----- - selectInverseClasses - "Fixed to update all selections now that the - selection invalidation has been optimised." - - classesSelected := classes asSet - removeAll: classesSelected; - yourself. - self - changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectNoCategories (in category 'accessing-categories') ----- - selectNoCategories - categoriesSelected := Set new. - self changed: #allSelections; changed: #categorySelected; updateClasses! Item was removed: - ----- Method: TestRunner>>selectNoClasses (in category 'accessing-classes') ----- - selectNoClasses - "Fixed to update all selections now that the - selection invalidation has been optimised." - - classesSelected := Set new. - self - changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>selectSubclasses (in category 'accessing-classes') ----- - selectSubclasses - "Fixed to update all selections now that the - selection invalidation has been optimised." - - | classesForPackages | - classesForPackages := self findClassesForCategories: categoriesSelected. - classesSelected := (classesSelected gather: [ :class | - class withAllSubclasses select: [ :each | - classesForPackages includes: each ] ]) - asSet. - self - changed: #allSelections; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>showDiffWith: (in category 'history saving') ----- - showDiffWith: aTestResult - | string diff | - - diff := result diff: aTestResult. - string := String streamContents: [:str| - str nextPutAll: '----------------'; cr. - str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr. - str nextPutAll: 'New passed: '. - diff first do: [:s| str nextPutAll: s printString, ' ']. - str cr. - str nextPutAll: 'New failures: '. - diff second do: [:s| str nextPutAll: s printString, ' ']. - str cr. - - str nextPutAll: 'New errors: '. - diff third do: [:s| str nextPutAll: s printString, ' ']. - str cr]. - - Workspace new contents: string; openLabel: 'SUnit Progress' - ! Item was removed: - ----- Method: TestRunner>>showHistoryMenu (in category 'history saving') ----- - showHistoryMenu - | selectionIndex selectedPreviousResult actionIndex | - selectionIndex := Project uiManager - chooseFrom: self historyMenuList - title: 'History:'. - "We pressed outside the menu" - selectionIndex isZero ifTrue: [^ self ]. - - "save current result is selected" - selectionIndex = 1 ifTrue: - [self previousRun addFirst: result. ^ self ]. - - selectedPreviousResult := self previousRun at: (selectionIndex - 1). - actionIndex := Project uiManager - chooseOptionFrom: #('delete' 'show diff') - title: 'Action:'. - actionIndex = 1 ifTrue: - [ self previousRun remove: selectedPreviousResult. ^ self ]. - actionIndex = 2 ifTrue: - [ self showDiffWith: selectedPreviousResult]. ! Item was removed: - ----- Method: TestRunner>>showProgress (in category 'history saving') ----- - showProgress - | testCaseClasses d string | - testCaseClasses := (self suiteAll tests collect: [:testCase | testCase class]) asSet. - - "At the end of the algorithm, d will contains all the diff between what was saved and the current result" - d := Dictionary new. - d at: #passed put: OrderedCollection new. - d at: #failures put: OrderedCollection new. - d at: #errors put: OrderedCollection new. - - testCaseClasses do: [ :cls | | t | - (cls class methodDict includesKey: #lastStoredRun) - ifTrue: [t := cls lastStoredRun. - (t at: #passed) do: [:s | - (result isErrorFor: cls selector: s) - ifTrue: [(d at: #errors) add: {cls . s}]. - (result isFailureFor: cls selector: s) - ifTrue: [(d at: #failures) add: {cls . s}] ]. - - (t at: #failures) do: [:s | (result isPassedFor: cls selector: s) - ifTrue: [(d at: #passed) add: {cls . s}]. - (result isErrorFor: cls selector: s) - ifTrue: [(d at: #errors) add: {cls . s}]]. - - (t at: #errors) do: [:s | (result isPassedFor: cls selector: s) - ifTrue: [(d at: #passed) add: {cls . s}]. - (result isFailureFor: cls selector: s) - ifTrue: [(d at: #failures) add: {cls . s}]]]]. - - - string := String streamContents: [:str| - str nextPutAll: '----------------'; cr. - str nextPutAll: 'Diff between current result and saved result'; cr. - str nextPutAll: 'New passed: '. - (d at: #passed) do: [:s| str nextPutAll: s printString, ' ']. - str cr. - str nextPutAll: 'New failures: '. - (d at: #failures) do: [:s| str nextPutAll: s printString, ' ']. - str cr. - - str nextPutAll: 'New errors: '. - (d at: #errors) do: [:s| str nextPutAll: s printString, ' ']. - str cr]. - - Workspace new contents: string; openLabel: 'SUnit Progress' string. - - ! Item was removed: - ----- Method: TestRunner>>sortCategories (in category 'accessing-categories') ----- - sortCategories - | selectedCategory | - selectedCategory := categoryIndex ifNotNil: [categories at: categoryIndex ifAbsent: []]. - categories := categories sort. - selectedCategory ifNotNil: - [categoryIndex := categories indexOf: selectedCategory]. - self changed: #categoryList! Item was removed: - ----- Method: TestRunner>>sortClass:before: (in category 'utilities') ----- - sortClass: firstHierarchyList before: secondHierarchyList - - 1 to: (firstHierarchyList size min: secondHierarchyList size) do: [ :index | - (firstHierarchyList at: index) == (secondHierarchyList at: index) - ifFalse: [ ^(firstHierarchyList at: index) name <= (secondHierarchyList at: index) name ] ]. - ^secondHierarchyList includes: firstHierarchyList last.! Item was removed: - ----- Method: TestRunner>>statusColor (in category 'accessing-testing') ----- - statusColor - result hasErrors ifTrue: [^ self userInterfaceTheme errorColor ifNil: [Color red]]. - result hasFailures ifTrue: [^ self userInterfaceTheme failureColor ifNil: [Color yellow]]. - ^ self userInterfaceTheme passColor ifNil: [Color green]! Item was removed: - ----- Method: TestRunner>>statusFrame (in category 'building') ----- - statusFrame - ^LayoutFrame new - leftFraction: 0.5 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self statusHeight! Item was removed: - ----- Method: TestRunner>>statusHeight (in category 'building') ----- - statusHeight - ^ ToolBuilder default inputFieldHeightFor: 3! Item was removed: - ----- Method: TestRunner>>statusMenu: (in category 'accessing-menu') ----- - statusMenu: aMenu - ^ aMenu - add: 'History' action: #showHistoryMenu; - add: 'Store result as progress reference' action: #storeResultIntoTestCases; - add: 'Show progress' action: #showProgress; - yourself! Item was removed: - ----- Method: TestRunner>>statusText (in category 'accessing-testing') ----- - statusText - ^ result printString.! Item was removed: - ----- Method: TestRunner>>statusTextColor (in category 'accessing-testing') ----- - statusTextColor - result hasErrors ifTrue: [^ self userInterfaceTheme errorTextColor ifNil: [Color black]]. - result hasFailures ifTrue: [^ self userInterfaceTheme failureTextColor ifNil: [Color black]]. - ^ self userInterfaceTheme passTextColor ifNil: [Color black]! Item was removed: - ----- Method: TestRunner>>storeResultIntoTestCases (in category 'history saving') ----- - storeResultIntoTestCases - - result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ] - ! Item was removed: - ----- Method: TestRunner>>suiteAll (in category 'accessing') ----- - suiteAll - ^ TestSuite new in: [ :suite | - classesSelected do: [ :each | - each isAbstract - ifFalse: [ each addToSuiteFromSelectors: suite ] ]. - suite name: (self label: 'Test' forSuite: suite) ].! Item was removed: - ----- Method: TestRunner>>suiteErrors (in category 'accessing') ----- - suiteErrors - ^ TestSuite new in: [ :suite | - suite - addTests: errorList; - name: (self label: 'Error' forSuite: suite) ].! Item was removed: - ----- Method: TestRunner>>suiteFailures (in category 'accessing') ----- - suiteFailures - ^ TestSuite new in: [ :suite | - suite - addTests: failedList; - name: (self label: 'Failure' forSuite: suite) ].! Item was removed: - ----- Method: TestRunner>>update (in category 'updating') ----- - update - self updateCategories; updateClasses! Item was removed: - ----- Method: TestRunner>>updateCategories (in category 'updating') ----- - updateCategories - categories := self findCategories. - categoriesSelected := categoriesSelected isNil - ifTrue: [ Set new ] - ifFalse: [ - categoriesSelected - select: [ :each | categories includes: each ] ]. - self changed: #categoryList; changed: #categorySelected.! Item was removed: - ----- Method: TestRunner>>updateClasses (in category 'updating') ----- - updateClasses - - | classesForCategories | - classesForCategories := self findClassesForCategories: categoriesSelected. - classes := classesForCategories asArray - replace: [ :class | class withAllSuperclasses reverseInPlace ]; - sort: [ :a :b | self sortClass: a before: b ]; - replace: [ :hierarchyList | hierarchyList last ]. - classesSelected := classesSelected - ifNil: [ classesForCategories ] - ifNotNil: [ - classesSelected - select: [ :each | classesForCategories includes: each ] ]. - classIndex - ifNil: [ classIndex := 0 ] - ifNotNil: [ - (classesSelected includes: (classes at: classIndex ifAbsent: [])) ifFalse: [ - classIndex := 0 ] ]. - self - changed: #classList; - changed: #classSelected; - changed: #hasRunnable! Item was removed: - ----- Method: TestRunner>>updateMethods (in category 'updating') ----- - updateMethods - - errorList := errorList select: #isInstalled. - failedList := failedList select: #isInstalled. - self - changed: #failedList; - changed: #errorList.! Item was removed: - ----- Method: TestRunner>>updateResults (in category 'updating') ----- - updateResults - "<lint: #expect rule: #guardingClause>" - "<lint: #expect rule: #longMethods>" - - self updateStatus: false. - failedList size = result failures size ifFalse: [ - failedList := result failures asArray - sort: [ :a :b | a printString <= b printString ]. - failedSelected := nil. - self - changed: #failedList; - changed: #failedSelected; - changed: #hasFailures; - changed: #hasProgress ]. - errorList size = result errors size ifFalse: [ - errorList := result errors asArray - sort: [ :a :b | a printString <= b printString ]. - errorSelected := nil. - self - changed: #errorList; - changed: #errorSelected; - changed: #hasErrors; - changed: #hasProgress; - changed: #classList ].! Item was removed: - ----- Method: TestRunner>>updateStatus: (in category 'updating') ----- - updateStatus: aBoolean - "Update the status display, at most once a second if aBoolean is true." - - (aBoolean and: [ lastUpdate = Time totalSeconds ]) - ifTrue: [ ^ self ]. - self changed: #statusText; changed: #statusColor; changed: #statusTextColor. - lastUpdate := Time totalSeconds.! Item was removed: - ----- Method: TestRunner>>windowIsClosing (in category 'private') ----- - windowIsClosing - SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self!
More information about the Squeak-dev mailing list |