Marcel Taeumel uploaded a new version of ToolsTests to project The Trunk: http://source.squeak.org/trunk/ToolsTests-mt.120.mcz
==================== Summary ====================
Name: ToolsTests-mt.120 Author: mt Time: 13 April 2023, 3:11:38.460682 pm UUID: 00d3150e-fa34-9548-8449-8a1a2fcd404f Ancestors: ToolsTests-mt.119
Complements Tools-mt.1198
=============== Diff against ToolsTests-mt.119 ===============
Item was changed: ----- Method: BrowserTest>>testSpawnHierarchy (in category 'tests') ----- testSpawnHierarchy | spawn | browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: browser messageCategoryList last. browser messageListIndex: (browser messageList size).
spawn := browser spawnHierarchy. + [self assert: spawn selectedClassName = browser selectedClassName. - [self assert: spawn selectedSystemCategory = browser selectedSystemCategory. - self assert: spawn selectedClassName = browser selectedClassName. self assert: spawn selectedMessageCategoryName = browser selectedMessageCategoryName. self assert: spawn messageListIndex = browser messageListIndex.] ensure: [ ToolBuilder default close: spawn topView ].!
Item was added: + BrowserTest subclass: #TreeBrowserTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'ToolsTests-Browser'!
Item was added: + ----- Method: TreeBrowserTest class>>shouldInheritSelectors (in category 'testing') ----- + shouldInheritSelectors + "We must pass all basic browser tests. And more." + + ^ true!
Item was added: + ----- Method: TreeBrowserTest>>setUp (in category 'running') ----- + setUp + + browser := TreeBrowser new.!
Item was added: + ----- Method: TreeBrowserTest>>testMsgNoSingleChildWithEmptyParent (in category 'tests - message list') ----- + testMsgNoSingleChildWithEmptyParent + + Smalltalk allClassesDo: [:cls | | rest parent | + browser setClass: cls. + rest := browser messageCategoryRoots asOrderedCollection. + [rest notEmpty] whileTrue: [ + parent := rest removeFirst. + (browser messageCategoryHasChildren: parent) + ifTrue: [ | children | + children := browser messageCategoryChildren: parent. + children size = 1 ifTrue: [ "Should only be possible if parent is actual category with messages" + browser selectMessageCategoryNamed: parent. + self assert: browser messageList notEmpty]. + rest addAll: children]] ]!
Item was added: + ----- Method: TreeBrowserTest>>testSysNoSingleChildWithEmptyParent (in category 'tests - system category list') ----- + testSysNoSingleChildWithEmptyParent + + | rest parent | + rest := browser systemCategoryRoots asOrderedCollection. + [rest notEmpty] whileTrue: [ + parent := rest removeFirst. + (browser systemCategoryHasChildren: parent) + ifTrue: [ | children | + children := browser systemCategoryChildren: parent. + children size = 1 ifTrue: [ "Should only be possible if parent is package or category with classes" + browser selectSystemCategory: parent. + self assert: (browser classList notEmpty + or: [(PackageOrganizer default packageNamed: parent ifAbsent: nil) notNil ])]. + rest addAll: children]]!
Item was added: + ----- Method: TreeBrowserTest>>testSystemCategoryPath (in category 'tests - system category list') ----- + testSystemCategoryPath + "For any class, the end of the current should end in the actual system category." + + | failedSelections | + failedSelections := Set new. + SystemOrganization categories do: [:cat | + (SystemOrganization listAtCategoryNamed: cat) ifNotEmpty: [:classes | | cls | + cls := self environment classNamed: classes first. + browser setClass: cls. + cat == browser systemCategoryPath last + ifFalse: [failedSelections add: cat]]]. + self + assert: failedSelections isEmpty + description: 'Not all system categories can be selected!!'.!