[squeak-dev] Squeak 4.6: ToolsTests-topa.72.mczcommits at source.squeak.org commits at source.squeak.orgFri Jun 5 20:21:18 UTC 2015
Chris Muller uploaded a new version of ToolsTests to project Squeak 4.6: http://source.squeak.org/squeak46/ToolsTests-topa.72.mcz ==================== Summary ==================== Name: ToolsTests-topa.72 Author: topa Time: 14 April 2015, 10:31:36.416 am UUID: 0c975601-52ad-4b6f-96a5-1197a85f7a32 Ancestors: ToolsTests-mt.71 Adapt BrowserTests to rely less on global state, namely SystemOrganization ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolsTests-Browser'! SystemOrganization addCategory: #'ToolsTests-Debugger'! SystemOrganization addCategory: #'ToolsTests-FileList'! SystemOrganization addCategory: #'ToolsTests-Inspector'! TestCase subclass: #BrowseTest instanceVariableNames: 'originalBrowserClass originalHierarchyBrowserClass' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: BrowseTest>>currentBrowsers (in category 'private') ----- currentBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: Browser]]) asSet! ----- Method: BrowseTest>>currentHierarchyBrowsers (in category 'private') ----- currentHierarchyBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: HierarchyBrowser]]) asSet! ----- Method: BrowseTest>>ensureMorphic (in category 'private') ----- ensureMorphic self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].! ----- Method: BrowseTest>>isMorphic (in category 'private') ----- isMorphic ^Smalltalk isMorphic! ----- Method: BrowseTest>>setUp (in category 'running') ----- setUp | systemNavigation | systemNavigation := SystemNavigation default. originalBrowserClass := systemNavigation browserClass. originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass. systemNavigation browserClass: nil. systemNavigation hierarchyBrowserClass: nil. ! ----- Method: BrowseTest>>tearDown (in category 'running') ----- tearDown | systemNavigation | systemNavigation := SystemNavigation default. systemNavigation browserClass: originalBrowserClass. systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.! ----- Method: BrowseTest>>testBrowseClass (in category 'testing') ----- testBrowseClass "self debug: #testBrowseClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ----- Method: BrowseTest>>testBrowseHierarchyClass (in category 'testing') ----- testBrowseHierarchyClass "self debug: #testBrowseHierarchyClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ----- Method: BrowseTest>>testBrowseHierarchyInstance (in category 'testing') ----- testBrowseHierarchyInstance "self debug: #testBrowseHierarchyInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ----- Method: BrowseTest>>testBrowseHierarchyMataclass (in category 'testing') ----- testBrowseHierarchyMataclass "self debug: #testBrowseHierarchyMataclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == Metaclass). opened delete ! ----- Method: BrowseTest>>testBrowseInstance (in category 'testing') ----- testBrowseInstance "self debug: #testBrowseInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ----- Method: BrowseTest>>testBrowseMetaclass (in category 'testing') ----- testBrowseMetaclass "self debug: #testBrowseMetaclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ----- Method: BrowseTest>>testFindReferencesToFloatNaN (in category 'testing') ----- testFindReferencesToFloatNaN self assert: (SystemNavigation new allCallsOn: (Float bindingOf: #NaN)) notEmpty! ----- Method: BrowseTest>>testSystemNavigationAllBehaviorsDo (in category 'testing') ----- testSystemNavigationAllBehaviorsDo | oc | oc := OrderedCollection new. SystemNavigation new allBehaviorsDo: [:c| oc add: c]. self assert: oc size = oc asSet size! TestCase subclass: #BrowserHierarchicalListTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! !BrowserHierarchicalListTest commentStamp: 'rkrk 8/24/2009 05:11' prior: 0! Tests the optional hierarchical class ordering of Browser.! ----- Method: BrowserHierarchicalListTest>>assertCorrectOrderOf:followedBy:in: (in category 'assertion') ----- assertCorrectOrderOf: classB followedBy: classA in: classCollection "classB comes before classA. Assert that classB is a superclass of classB or that a common superclass is in front of both" | commonSuperclasses commonSuperclass classAIndex classBIndex superIndex | classA == classB ifTrue: [^ self]. (classA inheritsFrom: classB) ifTrue: [^ self]. commonSuperclasses := classA withAllSuperclasses intersection: classB withAllSuperclasses. commonSuperclass := commonSuperclasses first. (classCollection includes: commonSuperclass) ifFalse: [^ self]. classAIndex := classCollection indexOf: classA. classBIndex := classCollection indexOf: classB. superIndex := classCollection indexOf: commonSuperclass. (superIndex < classAIndex and: [superIndex < classBIndex]) ifTrue: [^self]. self fail.! ----- Method: BrowserHierarchicalListTest>>hierarchicalClassListForCategory: (in category 'helper') ----- hierarchicalClassListForCategory: category ^ Browser new selectSystemCategory: category; hierarchicalClassList.! ----- Method: BrowserHierarchicalListTest>>nameToClass: (in category 'helper') ----- nameToClass: classNameWithIndent ^ Smalltalk classNamed: classNameWithIndent withoutLeadingBlanks asSymbol! ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically1 (in category 'tests') ----- testListClassesHierarchically1 | result classes category | category := 'Collections-Abstract'. result := self hierarchicalClassListForCategory: category. self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size. classes := result collect: [:ea | self nameToClass: ea]. classes withIndexDo: [:ea : i | classes from: 1 to: i do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].! ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically2 (in category 'tests') ----- testListClassesHierarchically2 | result classes category | category := 'Tools-Browser'. result := self hierarchicalClassListForCategory: category. self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size. classes := result collect: [:ea | self nameToClass: ea]. classes withIndexDo: [:ea : i | classes from: 1 to: i do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].! ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchicallyIndent (in category 'tests') ----- testListClassesHierarchicallyIndent | result dict | result := self hierarchicalClassListForCategory: 'Tools-Browser'. "Create class->indent mapping" dict := result inject: Dictionary new into: [:classIndentMapping :className | | indent | indent := className count: [:char | char = Character space or: [char = Character tab]]. classIndentMapping at: (self nameToClass: className) put: indent. classIndentMapping]. "assert that indent of class is larger than indent of superclass" dict keysAndValuesDo: [:class :myIndent | dict at: class superclass ifPresent: [:superIndent | self assert: myIndent > superIndent]].! TestCase subclass: #BrowserTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! !BrowserTest commentStamp: 'fbs 3/4/2011 07:22' prior: 0! I provide the test suite for Browser. ! ----- Method: BrowserTest>>setUp (in category 'running') ----- setUp browser := Browser new.! ----- Method: BrowserTest>>testAlphabetizeMessageCategories (in category 'as yet unclassified') ----- testAlphabetizeMessageCategories browser selectSystemCategory: browser class category. self deny: browser alphabetizeMessageCategories. browser selectClass: browser class. browser metaClassIndicated: false. self assert: browser alphabetizeMessageCategories. self assert: browser classOrMetaClassOrganizer categories isSorted. browser metaClassIndicated: true. self assert: browser alphabetizeMessageCategories. self assert: browser classOrMetaClassOrganizer categories isSorted.! ----- Method: BrowserTest>>testAlphabetizeMessageCategoriesLeavesClassSelected (in category 'as yet unclassified') ----- testAlphabetizeMessageCategoriesLeavesClassSelected browser selectSystemCategory: browser class category. browser selectClassNamed: browser class name. "This is a no-op." browser alphabetizeMessageCategories. self assert: browser selectedClassName = browser class name.! ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlace (in category 'testing - message list') ----- testAlphabetizingMethodsPreservesPlace | oldCategory oldMethod | oldCategory := 'breakpoints'. oldMethod := #toggleBreakOnEntry. browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: oldCategory. browser selectMessageNamed: oldMethod. browser alphabetizeMessageCategories. self assert: browser selectedMessageCategoryName = oldCategory. self assert: browser selectedMessageName = oldMethod.! ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlaceWhenNoMessageCategorySelected (in category 'testing - message list') ----- testAlphabetizingMethodsPreservesPlaceWhenNoMessageCategorySelected browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: nil. browser selectMessageNamed: nil. browser alphabetizeMessageCategories. self assert: browser selectedMessageCategoryName = nil. self assert: browser selectedMessageName = nil.! ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlaceWhenNoMethodSelected (in category 'testing - message list') ----- testAlphabetizingMethodsPreservesPlaceWhenNoMethodSelected | oldCategory | oldCategory := 'breakpoints'. browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: oldCategory. browser selectMessageNamed: nil. browser alphabetizeMessageCategories. self assert: browser selectedMessageCategoryName = oldCategory. self assert: browser selectedMessageName = nil.! ----- Method: BrowserTest>>testBuildMessageCategoryBrowserEditString (in category 'as yet unclassified') ----- testBuildMessageCategoryBrowserEditString | spawn | browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 1. browser messageListIndex: 1. spawn := browser buildMessageCategoryBrowserEditString: 'We don''t yet test that we do the right thing with this string!!'. [self assert: spawn selectedSystemCategory = browser selectedSystemCategory. self assert: spawn selectedClass = browser selectedClass. self assert: spawn messageCategoryListIndex = browser messageCategoryListIndex. self assert: spawn messageListIndex = browser messageListIndex] ensure: [ ToolBuilder default close: spawn topView ].! ----- Method: BrowserTest>>testBuildMessageCategoryBrowserEditStringNoCategorySelected (in category 'as yet unclassified') ----- testBuildMessageCategoryBrowserEditStringNoCategorySelected browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 0. self assert: (browser buildMessageCategoryBrowserEditString: 'foo') isNil.! ----- Method: BrowserTest>>testChangeMessageCategoriesLeavesClassSelected (in category 'as yet unclassified') ----- testChangeMessageCategoriesLeavesClassSelected browser selectSystemCategory: browser class category. browser selectClassNamed: browser class name. "This is a no-op." browser changeMessageCategories: browser classOrMetaClassOrganizer printString. self assert: browser selectedClassName = browser class name.! ----- Method: BrowserTest>>testClassCommentAnnotation (in category 'as yet unclassified') ----- testClassCommentAnnotation | annotation | browser selectSystemCategory: browser class category. browser selectClass: browser class. annotation := browser annotationForClassCommentFor: browser class. self assert: (annotation includesSubString: browser class organization commentStamp). self assert: (annotation includesSubString: 'class comment for'). self assert: (annotation includesSubString: browser className).! ----- Method: BrowserTest>>testClassCommentAnnotationIgnoresParameter (in category 'as yet unclassified') ----- testClassCommentAnnotationIgnoresParameter | annotation | browser selectSystemCategory: browser class category. browser selectClass: browser class. "And the method ignores the parameter:" annotation := browser annotationForClassCommentFor: browser class superclass. self assert: (annotation includesSubString: browser className).! ----- Method: BrowserTest>>testClassCommentViewingPersists (in category 'as yet unclassified') ----- testClassCommentViewingPersists browser selectSystemCategory: browser class category. self assert: browser classList size > 1 description: 'We use the first TWO classes in the category!!'. browser classListIndex: 1. browser metaClassIndicated: false. browser editComment. browser classListIndex: 2. self assert: browser editSelection = #editComment.! ----- Method: BrowserTest>>testClassDefinitionAnnotation (in category 'as yet unclassified') ----- testClassDefinitionAnnotation browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser class comment equals: (browser annotationForClassDefinitionFor: browser class). "And the method ignores the parameter:" self assert: browser class comment equals: (browser annotationForClassDefinitionFor: browser class superclass).! ----- Method: BrowserTest>>testContentsNewClass (in category 'as yet unclassified') ----- testContentsNewClass browser selectSystemCategory: browser class category. self assert: (Class template: browser selectedSystemCategory) equals: browser contents. self flag: #todo. "I don't know how to test the other half of this: see Browser >> #newClassContents".! ----- Method: BrowserTest>>testContentsSelection (in category 'as yet unclassified') ----- testContentsSelection browser selectSystemCategory: browser class category. browser selectClass: browser class. "No category or message selected." self assert: browser contentsSelection isEmpty. "Category selected, but no message selected." browser messageCategoryListIndex: 1. browser selectMessageNamed: browser messageList first. self assert: browser contentsSelection isEmpty. "Category and message selected." browser selectMessageNamed: nil. self deny: browser contentsSelection isEmpty.! ----- Method: BrowserTest>>testCreateHierarchyTreeOf (in category 'as yet unclassified') ----- testCreateHierarchyTreeOf "Empty." self assert: (browser createHierarchyTreeOf: #()) isEmpty. "Single class." self assert: { Browser -> #() } = (browser createHierarchyTreeOf: { Browser }). "Single class + 1 subclass" self assert: { Browser->{HierarchyBrowser->#()} } = (browser createHierarchyTreeOf: { Browser. HierarchyBrowser. }). "Single class + 2 subclasses" self assert: { Browser->{HierarchyBrowser->#() . FileContentsBrowser->#()} } = (browser createHierarchyTreeOf: { Browser. HierarchyBrowser. FileContentsBrowser. }). "Superclass, class, subclass" self assert: { CodeHolder->{Browser->{HierarchyBrowser->#()}} } = (browser createHierarchyTreeOf: { CodeHolder. Browser. HierarchyBrowser. }). "Two 'unrelated' classes" self assert: {Browser->#() . SmallInteger->#()} = (browser createHierarchyTreeOf: { Browser. SmallInteger }). "Two 'unrelated' classes and a common ancestor" self assert: {Browser->#() . SmallInteger->#() . ProtoObject->#()} = (browser createHierarchyTreeOf: { Browser. SmallInteger. ProtoObject }).! ----- Method: BrowserTest>>testDefaultClassList (in category 'as yet unclassified') ----- testDefaultClassList browser selectSystemCategory: nil. self assert: browser defaultClassList isEmpty. browser selectSystemCategory: Browser category. self assert: browser defaultClassList = (SystemOrganization listAtCategoryNamed: Browser category)! ----- Method: BrowserTest>>testFileOutMessageCategories (in category 'as yet unclassified') ----- testFileOutMessageCategories | fileName | browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 1. "Handcrafted from ClassDescription>>fileOutCategory:asHtml:" fileName := browser selectedClass name, '-', browser selectedMessageCategoryName, FileDirectory dot, 'st'. self deny: (FileDirectory default fileExists: fileName). [browser fileOutMessageCategories. self assert: (FileDirectory default fileExists: fileName). ] ensure: [FileDirectory default deleteFileNamed: fileName].! ----- Method: BrowserTest>>testFlattenHierarchyTreeOnIndent (in category 'as yet unclassified') ----- testFlattenHierarchyTreeOnIndent | flatten | flatten := [:coll | browser flattenHierarchyTree: (browser createHierarchyTreeOf: coll) on: OrderedCollection new indent: '']. "Empty collection." self assert: (flatten value: #()) isEmpty. "Single class." self assert: (OrderedCollection with: 'Browser') = (flatten value: {Browser}). "Single class + subclass." self assert: (OrderedCollection with: 'Browser' with: ' HierarchyBrowser') = (flatten value: {Browser. HierarchyBrowser}). "Single class + 2 subclasses" self assert: (OrderedCollection with: 'Browser' with: ' HierarchyBrowser' with: ' FileContentsBrowser') = (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). "Superclass, class, subclass" self assert: (OrderedCollection with: 'CodeHolder' with: ' Browser' with: ' HierarchyBrowser') = (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). "Two 'unrelated' classes" self assert: (OrderedCollection with: 'Browser' with: 'SmallInteger') = (flatten value: { Browser. SmallInteger }). "Two 'unrelated' classes and a common ancestor" self assert: (OrderedCollection with: 'Browser' with: 'SmallInteger' with: 'ProtoObject') = (flatten value: { Browser. SmallInteger. ProtoObject }).! ----- Method: BrowserTest>>testFlattenHierarchyTreeOnIndentBy (in category 'as yet unclassified') ----- testFlattenHierarchyTreeOnIndentBy | flatten | flatten := [:coll | browser flattenHierarchyTree: (browser createHierarchyTreeOf: coll) on: OrderedCollection new indent: '' by: 'x']. "Empty collection." self assert: (flatten value: #()) isEmpty. "Single class." self assert: (OrderedCollection with: 'Browser') = (flatten value: {Browser}). "Single class + subclass." self assert: (OrderedCollection with: 'Browser' with: 'xHierarchyBrowser') = (flatten value: {Browser. HierarchyBrowser}). "Single class + 2 subclasses" self assert: (OrderedCollection with: 'Browser' with: 'xHierarchyBrowser' with: 'xFileContentsBrowser') = (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). "Superclass, class, subclass" self assert: (OrderedCollection with: 'CodeHolder' with: 'xBrowser' with: 'xxHierarchyBrowser') = (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). "Two 'unrelated' classes" self assert: (OrderedCollection with: 'Browser' with: 'SmallInteger') = (flatten value: { Browser. SmallInteger }). "Two 'unrelated' classes and a common ancestor" self assert: (OrderedCollection with: 'Browser' with: 'SmallInteger' with: 'ProtoObject') = (flatten value: { Browser. SmallInteger. ProtoObject }).! ----- Method: BrowserTest>>testGetSystemCategoryListIndex (in category 'as yet unclassified') ----- testGetSystemCategoryListIndex | cat | cat := browser systemCategoryList first. browser selectSystemCategory: cat. self assert: browser systemCategoryListIndex = (browser systemCategoryList indexOf: browser selectedSystemCategory).! ----- Method: BrowserTest>>testHasClassSelected (in category 'as yet unclassified') ----- testHasClassSelected browser selectSystemCategory: browser class category. self deny: browser hasClassSelected. browser selectClass: browser class. self assert: browser hasClassSelected. browser selectClass: nil. self deny: browser hasClassSelected. browser selectClassNamed: browser class name asString. self assert: browser hasClassSelected.! ----- Method: BrowserTest>>testHasMessageCategorySelected (in category 'as yet unclassified') ----- testHasMessageCategorySelected browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 0. self deny: browser hasMessageCategorySelected. browser messageCategoryListIndex: 1. self assert: browser hasMessageCategorySelected. browser messageCategoryListIndex: 0. self deny: browser hasMessageCategorySelected.! ----- Method: BrowserTest>>testHasMessageSelected (in category 'as yet unclassified') ----- testHasMessageSelected browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 1. self deny: browser hasMessageSelected. browser messageListIndex: 0. self deny: browser hasMessageSelected. browser messageListIndex: 1. self assert: browser hasMessageSelected. browser messageListIndex: 0. self deny: browser hasMessageSelected.! ----- Method: BrowserTest>>testHomeCategory (in category 'as yet unclassified') ----- testHomeCategory "This also 'just happens' to test #selectOriginalCategoryForCurrentMethod. It's not appropriate to directly test a private method. (It's a private method because its comment says so, not its category.)" browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 0. "Select -- all --" browser selectMessageNamed: browser messageList first. browser showHomeCategory. self assert: browser selectedMessageCategoryName = (browser class organization categoryOfElement: browser selectedMessageName).! ----- Method: BrowserTest>>testKeepMethodSelectedWhenChangingClass (in category 'testing - message list') ----- testKeepMethodSelectedWhenChangingClass browser selectSystemCategory: SequenceableCollection category. browser selectClass: SequenceableCollection. browser selectMessageNamed: #add:. self assert: browser selectedMessageName = #add:. "Even though we have no message category selected, stay looking at the #add: method." browser selectClass: Collection. self assert: browser selectedMessageName = #add:.! ----- Method: BrowserTest>>testLabelStringAlwaysShowsBrowserType (in category 'as yet unclassified') ----- testLabelStringAlwaysShowsBrowserType browser selectSystemCategory: browser class category. self assert: (browser labelString includesSubString: 'System Browser'). browser selectClass: browser class. self assert: (browser labelString includesSubString: 'System Browser'). browser selectSystemCategory: DependencyBrowser category. browser selectClass: DependencyBrowser. self assert: (browser labelString includesSubString: 'System Browser').! ----- Method: BrowserTest>>testLabelStringOfNewBrowserShowsBrowserType (in category 'as yet unclassified') ----- testLabelStringOfNewBrowserShowsBrowserType self assert: 'System Browser' equals: browser labelString.! ----- Method: BrowserTest>>testLabelStringShowsBrowsedClassName (in category 'as yet unclassified') ----- testLabelStringShowsBrowsedClassName browser selectSystemCategory: DependencyBrowser category. browser selectClass: DependencyBrowser. self assert: (browser labelString includesSubString: DependencyBrowser name).! ----- Method: BrowserTest>>testMessageCatListSingleton (in category 'as yet unclassified') ----- testMessageCatListSingleton | catName | browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser messageCatListSingleton = #(). catName := browser messageCategoryList second. browser selectMessageCategoryNamed: catName. self assert: browser messageCatListSingleton = {catName}.! ----- Method: BrowserTest>>testMessageCategoryList (in category 'as yet unclassified') ----- testMessageCategoryList browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser messageCategoryList = ({ClassOrganizer allCategory}, browser class organization categories). browser selectClass: nil. self assert: browser messageCategoryList = #(). browser selectClass: browser class. browser metaClassIndicated: true. self assert: browser messageCategoryList = ({ClassOrganizer allCategory}, browser class classSide organization categories).! ----- Method: BrowserTest>>testMessageCategoryListIndex (in category 'as yet unclassified') ----- testMessageCategoryListIndex browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser messageCategoryList size > 1 description: 'Sanity check: test refers to first two categories.'. browser messageCategoryListIndex: 0. self assert: browser selectedMessageCategoryName isNil. browser messageCategoryListIndex: 1. self assert: browser selectedMessageCategoryName = browser messageCategoryList first. browser messageListIndex: 1. browser messageCategoryListIndex: 2. self assert: browser selectedMessageName isNil description: 'Changing category deselects method'.! ----- Method: BrowserTest>>testMessageList (in category 'as yet unclassified') ----- testMessageList browser selectSystemCategory: browser class category. browser selectClass: nil. self assert: browser messageList isEmpty. browser selectClass: browser class. browser messageCategoryListIndex: 0. self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. browser messageCategoryListIndex: 1. "-- all --" self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. browser messageCategoryListIndex: 2. self assert: browser messageList = (browser classOrMetaClassOrganizer listAtCategoryNumber: 1). browser metaClassIndicated: true. browser messageCategoryListIndex: 0. self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. browser messageCategoryListIndex: 1. "-- all --" self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. browser messageCategoryListIndex: 2. self assert: browser messageList = (browser classOrMetaClassOrganizer listAtCategoryNumber: 1).! ----- Method: BrowserTest>>testMetaClassIndicatedFalseOnExistingClass (in category 'as yet unclassified') ----- testMetaClassIndicatedFalseOnExistingClass browser selectSystemCategory: browser class category. browser selectClass: browser class. browser metaClassIndicated: false. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self deny: browser contents isEmpty. "It shows the class definition." self deny: browser messageCategoryList isEmpty. self assert: browser messageList = (browser class organization allMethodSelectors). self assert: browser editSelection = #editClass.! ----- Method: BrowserTest>>testMetaClassIndicatedNotOnNoClass (in category 'as yet unclassified') ----- testMetaClassIndicatedNotOnNoClass browser selectSystemCategory: browser class category. browser selectClass: nil. browser metaClassIndicated: false. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self deny: browser contents isEmpty. "It shows the class definition." self assert: browser messageCategoryList isEmpty. self assert: browser messageList isEmpty. self assert: browser editSelection = #newClass.! ----- Method: BrowserTest>>testMetaClassIndicatedNotWithNoSystemCategorySelected (in category 'as yet unclassified') ----- testMetaClassIndicatedNotWithNoSystemCategorySelected browser selectSystemCategory: nil. browser metaClassIndicated: false. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self assert: browser contents isEmpty. "It shows the Class definition." self assert: browser messageCategoryList isEmpty. self assert: browser editSelection = #none.! ----- Method: BrowserTest>>testMetaClassIndicatedOnNoClass (in category 'as yet unclassified') ----- testMetaClassIndicatedOnNoClass browser selectSystemCategory: browser class category. browser selectClass: nil. browser metaClassIndicated: true. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self assert: browser contents isEmpty. self assert: browser messageCategoryList isEmpty. self assert: browser messageList isEmpty. self assert: browser editSelection = #none.! ----- Method: BrowserTest>>testMetaClassIndicatedTrueOnExistingClass (in category 'as yet unclassified') ----- testMetaClassIndicatedTrueOnExistingClass browser selectSystemCategory: browser class category. browser selectClass: browser class. browser metaClassIndicated: true. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self deny: browser contents isEmpty. "It shows the Class definition." self deny: browser messageCategoryList isEmpty. self assert: browser messageList = (browser class classSide organization allMethodSelectors).! ----- Method: BrowserTest>>testMetaClassIndicatedWithNoSystemCategorySelected (in category 'as yet unclassified') ----- testMetaClassIndicatedWithNoSystemCategorySelected browser selectSystemCategory: nil. browser metaClassIndicated: true. self assert: browser messageListIndex = 0. self assert: browser messageCategoryListIndex = 0. self assert: browser contents isEmpty. "It shows the Class definition." self assert: browser messageCategoryList isEmpty. self assert: browser editSelection = #none.! ----- Method: BrowserTest>>testRawMessageCategoryList (in category 'as yet unclassified') ----- testRawMessageCategoryList browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser rawMessageCategoryList = browser class organization categories. browser selectClass: nil. self assert: browser rawMessageCategoryList = #(). browser selectClass: browser class. browser metaClassIndicated: true. self assert: browser rawMessageCategoryList = browser class classSide organization categories.! ----- Method: BrowserTest>>testSelectCategoryForClass (in category 'as yet unclassified') ----- testSelectCategoryForClass browser selectCategoryForClass: Browser. self assert: browser selectedSystemCategory = Browser category. browser selectCategoryForClass: TestCase. self assert: browser selectedSystemCategory = TestCase category.! ----- Method: BrowserTest>>testSelectClass (in category 'as yet unclassified') ----- testSelectClass browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser hasClassSelected. browser selectClass: nil. self deny: browser hasClassSelected.! ----- Method: BrowserTest>>testSelectClassEditSelectionNoClass (in category 'as yet unclassified') ----- testSelectClassEditSelectionNoClass browser selectSystemCategory: browser class category. browser selectClass: nil. self assert: browser editSelection = #newClass.! ----- Method: BrowserTest>>testSelectClassEditSelectionWhenCommentSelected (in category 'as yet unclassified') ----- testSelectClassEditSelectionWhenCommentSelected | editSelection | browser selectSystemCategory: Heap category. browser selectClass: Heap. browser editComment. browser messageListIndex: 0. browser messageListIndex: 0. editSelection := browser editSelection. browser selectClass: Interval. self assert: browser editSelection = editSelection.! ----- Method: BrowserTest>>testSelectClassEditSelectionWhenEditingClass (in category 'as yet unclassified') ----- testSelectClassEditSelectionWhenEditingClass browser selectSystemCategory: Heap category. browser selectClass: Heap. browser metaClassIndicated: false. browser messageListIndex: 0. browser messageListIndex: 0. browser selectClass: Interval. self assert: browser editSelection = #editClass.! ----- Method: BrowserTest>>testSelectClassEditSelectionWhenEditingMetaclass (in category 'as yet unclassified') ----- testSelectClassEditSelectionWhenEditingMetaclass browser selectSystemCategory: Heap category. browser selectClass: Heap. browser metaClassIndicated: true. browser messageListIndex: 0. browser messageListIndex: 0. browser selectClass: Interval. self assert: browser editSelection = #editClass.! ----- Method: BrowserTest>>testSelectClassEditSelectionWhenMsgSelected (in category 'as yet unclassified') ----- testSelectClassEditSelectionWhenMsgSelected browser selectSystemCategory: Heap category. browser selectClass: Heap. browser selectMessageCategoryNamed: 'adding'. browser messageListIndex: (browser messageList indexOf: #add:). browser selectClass: Interval. self assert: browser editSelection = #editMessage.! ----- Method: BrowserTest>>testSelectClassEditSelectionWhenNoMsgButCatSelected (in category 'as yet unclassified') ----- testSelectClassEditSelectionWhenNoMsgButCatSelected browser selectSystemCategory: Heap category. browser selectClass: Heap. browser selectMessageCategoryNamed: 'adding'. browser messageListIndex: 0. browser selectClass: Interval. self assert: browser editSelection = #newMessage.! ----- Method: BrowserTest>>testSelectClassNamed (in category 'as yet unclassified') ----- testSelectClassNamed browser selectSystemCategory: browser class category. browser selectClassNamed: browser class name. self assert: browser selectedClassName = browser class name. browser selectClassNamed: nil. self assert: browser selectedClassName isNil. browser selectClassNamed: browser class name asString. self assert: browser selectedClassName = browser class name.! ----- Method: BrowserTest>>testSelectClassNamedPreservesPlace (in category 'as yet unclassified') ----- testSelectClassNamedPreservesPlace | commonCategory commonSelector otherClass | browser selectSystemCategory: browser class category. otherClass := HierarchyBrowser. "Unlikely to move out of Browser's package!!" browser selectClassNamed: browser class name. commonCategory := (browser class organization categories intersection: otherClass organization categories) first. commonSelector := #classList. browser selectMessageCategoryNamed: commonCategory. browser selectMessageNamed: commonSelector. browser selectClass: otherClass. self assert: browser selectedClassName = otherClass name. self assert: browser selectedMessageCategoryName = commonCategory. self assert: browser selectedMessageName = commonSelector.! ----- Method: BrowserTest>>testSelectClassReselectsMessage (in category 'as yet unclassified') ----- testSelectClassReselectsMessage "Colections-Sequences contains a number of classes with similar protocols. In particular, several classes have a method called #add: in a category 'adding'." | selectedMsgCat selectedMethod | selectedMsgCat := 'adding'. selectedMethod := #add:. browser selectSystemCategory: Heap category. browser selectClass: Heap. browser selectMessageCategoryNamed: selectedMsgCat. browser messageListIndex: (browser messageList indexOf: selectedMethod). browser selectClass: Interval. self assert: browser selectedMessageCategoryName = selectedMsgCat. self assert: browser selectedMessageName = selectedMethod.! ----- Method: BrowserTest>>testSelectClassSelectsClass (in category 'as yet unclassified') ----- testSelectClassSelectsClass browser selectSystemCategory: browser class category. browser selectClass: browser class. self assert: browser classListIndex ~= 0. self assert: browser selectedClass = browser class. self assert: browser selectedClassName = browser class name.! ----- Method: BrowserTest>>testSelectClassWhenNothingSelected (in category 'as yet unclassified') ----- testSelectClassWhenNothingSelected self assert: browser editSelection = #none.! ----- Method: BrowserTest>>testSelectMessageCategoryEditSelection (in category 'as yet unclassified') ----- testSelectMessageCategoryEditSelection browser selectSystemCategory: browser class category. browser selectClass: browser class. browser selectMessageCategoryNamed: browser messageCategoryList first. self assert: browser editSelection = #newMessage.! ----- Method: BrowserTest>>testSelectMessageCategoryEditSelectionNoMsgCat (in category 'as yet unclassified') ----- testSelectMessageCategoryEditSelectionNoMsgCat browser selectSystemCategory: browser class category. browser selectClass: browser class. . browser messageCategoryListIndex: 0. self assert: browser editSelection = #editClass.! ----- Method: BrowserTest>>testSelectMessageCategoryEditSelectionNoMsgCatNoClass (in category 'as yet unclassified') ----- testSelectMessageCategoryEditSelectionNoMsgCatNoClass browser selectSystemCategory: browser class category. browser selectClass: nil. . browser messageCategoryListIndex: 0. self assert: browser editSelection = #newClass.! ----- Method: BrowserTest>>testSelectMessageCategoryNamed (in category 'as yet unclassified') ----- testSelectMessageCategoryNamed | catName | browser selectSystemCategory: browser class category. browser selectClass: browser class. catName := browser messageCategoryList anyOne. browser selectMessageCategoryNamed: catName. self assert: browser selectedMessageCategoryName = catName.! ----- Method: BrowserTest>>testSelectMessageNamed (in category 'as yet unclassified') ----- testSelectMessageNamed browser selectSystemCategory: browser class category. browser selectClass: browser class. browser messageCategoryListIndex: 1. browser selectMessageNamed: browser messageList first. self assert: browser selectedMessageName = browser messageList first. self assert: browser messageListIndex = 1. browser selectMessageNamed: nil. self assert: browser selectedMessageName isNil. self assert: browser messageListIndex = 0. browser selectMessageNamed: browser messageList second. self assert: browser selectedMessageName = browser messageList second. self assert: browser messageListIndex = 2. browser selectMessageNamed: browser messageList first asString. self assert: browser selectedMessageName = browser messageList first. self assert: browser messageListIndex = 1.! ----- Method: BrowserTest>>testSelectedClass (in category 'as yet unclassified') ----- testSelectedClass browser selectSystemCategory: browser class category. browser classListIndex: 0. self assert: browser classListIndex = 0. self assert: browser selectedClass isNil. browser classListIndex: 1. self assert: browser classListIndex = 1. self assert: browser selectedClass notNil.! ----- Method: BrowserTest>>testSelectedEnvironment (in category 'as yet unclassified') ----- testSelectedEnvironment browser selectSystemCategory: browser class category. self assert: browser selectedEnvironment = Smalltalk. browser selectSystemCategory: nil. self assert: browser selectedEnvironment isNil.! ----- Method: BrowserTest>>testSelectedSystemCategory (in category 'as yet unclassified') ----- testSelectedSystemCategory | cat newCat | cat := browser systemCategoryList first. newCat := browser systemCategoryList second. browser selectSystemCategory: cat. self assert: browser selectedSystemCategory = cat. browser systemCategoryListIndex: 2. self assert: browser selectedSystemCategory = newCat.! ----- Method: BrowserTest>>testShowHomeCategory (in category 'as yet unclassified') ----- testShowHomeCategory browser selectSystemCategory: browser class category. browser selectClass: browser class. "Select '--all--'." browser selectMessageCategoryNamed: browser messageCategoryList first. browser selectMessageNamed: browser messageList first. browser showHomeCategory. self assert: browser messageCategoryListIndex > 1.! ----- Method: BrowserTest>>testSpawnHierarchy (in category 'as yet unclassified') ----- 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 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 ].! ----- Method: BrowserTest>>testSystemCategoryListIndex (in category 'as yet unclassified') ----- testSystemCategoryListIndex | oldCat | browser systemCategoryListIndex: 1. oldCat := browser selectedSystemCategory. self assert: browser selectedSystemCategory = browser systemCategoryList first. browser systemCategoryListIndex: 2. self deny: browser selectedSystemCategory = oldCat. self assert: browser selectedSystemCategory = browser systemCategoryList second.! TestCase subclass: #DebuggerExtensionsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Debugger'! ----- Method: DebuggerExtensionsTest>>testBooleansGeneralise (in category 'testing - canonical argument names') ----- testBooleansGeneralise self assert: Boolean name equals: true canonicalArgumentName. self assert: Boolean name equals: false canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testByteStringsGeneralise (in category 'testing - canonical argument names') ----- testByteStringsGeneralise self assert: String name equals: ByteString new canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testClassesGeneralise (in category 'testing - canonical argument names') ----- testClassesGeneralise self assert: Class name equals: Class new canonicalArgumentName. self assert: Class name equals: 1 class canonicalArgumentName. self assert: Class name equals: true class canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testCollectionsGeneralise (in category 'testing - canonical argument names') ----- testCollectionsGeneralise self assert: Collection name equals: Array new canonicalArgumentName. self assert: Collection name equals: OrderedCollection new canonicalArgumentName. self assert: Collection name equals: LinkedList new canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testFloatsGeneralise (in category 'testing - canonical argument names') ----- testFloatsGeneralise self assert: Number name equals: 1.0 canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testFractionsGeneralise (in category 'testing - canonical argument names') ----- testFractionsGeneralise self assert: Number name equals: (1 / 2) canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testIntegersDontGeneralise (in category 'testing - canonical argument names') ----- testIntegersDontGeneralise self assert: Integer name equals: 1 canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testLargeNegativeIntegersGeneralise (in category 'testing - canonical argument names') ----- testLargeNegativeIntegersGeneralise self assert: Integer name equals: LargeNegativeInteger initializedInstance canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testLargePositiveIntegersGeneralise (in category 'testing - canonical argument names') ----- testLargePositiveIntegersGeneralise self assert: Integer name equals: LargePositiveInteger initializedInstance canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testOtherObjectsDontGeneralise (in category 'testing - canonical argument names') ----- testOtherObjectsDontGeneralise self assert: Behavior name equals: Behavior new canonicalArgumentName. self assert: UndefinedObject name equals: nil canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testScaledDecimalsGeneralise (in category 'testing - canonical argument names') ----- testScaledDecimalsGeneralise self assert: Number name equals: 2.00s2 canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testStringsDontGeneralise (in category 'testing - canonical argument names') ----- testStringsDontGeneralise self assert: String name equals: String new canonicalArgumentName! ----- Method: DebuggerExtensionsTest>>testWideStringsGeneralise (in category 'testing - canonical argument names') ----- testWideStringsGeneralise self assert: String name equals: WideString new canonicalArgumentName! TestCase subclass: #DebuggerUnwindBug instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Debugger'! ----- Method: DebuggerUnwindBug>>testUnwindBlock (in category 'testing') ----- testUnwindBlock "test if unwind blocks work properly" | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. "deadlock on the semaphore" process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "terminate process" process terminate. self assert: sema isSignaled. ! ----- Method: DebuggerUnwindBug>>testUnwindDebugger (in category 'testing') ----- testUnwindDebugger "test if unwind blocks work properly when a debugger is closed" | sema process debugger top | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "everything set up here - open a debug notifier" debugger := Debugger openInterrupt: 'test' onProcess: process. "get into the debugger" debugger debug. top := debugger topView. "set top context" debugger toggleContextStackIndex: 1. "close debugger" top delete. "and see if unwind protection worked" self assert: sema isSignaled.! TestCase subclass: #DependencyBrowserTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: DependencyBrowserTest>>setUp (in category 'running') ----- setUp browser := DependencyBrowser new.! ----- Method: DependencyBrowserTest>>testBrowse (in category 'testing - buttons') ----- testBrowse | b | browser packageListIndex: (browser packageList indexOf: #Collections). browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). browser classDepsIndex: (browser classDeps indexOf: #Scanner). browser classListIndex: (browser classList indexOf: #Symbol). browser messageListIndex: 1. b := browser browseMethodFull. self assert: b notNil. [self assert: b selectedMessageName = (browser messageList at: browser messageListIndex) ] ensure: [ToolBuilder default close: b topView]! ----- Method: DependencyBrowserTest>>testClassList (in category 'testing - class list') ----- testClassList "Warning!! When Collections' dependencies change, this test may start to fail!!" self assert: #() equals: browser classList description: 'classList before package selection'. browser packageListIndex: (browser packageList indexOf: #Collections). self assert: #() equals: browser classList description: 'classList after selecting Collections'. browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). self assert: #() equals: browser classList description: 'classList after selecting Compiler'. browser classDepsIndex: (browser classDeps indexOf: #Scanner). self assert: #(Character Symbol 'Symbol class') equals: browser classList description: 'classList after selecting Scanner class'. browser classListIndex: (browser classList indexOf: #Symbol). self assert: #(Character Symbol 'Symbol class') equals: browser classList description: 'classList after selecting Symbol class'.! ----- Method: DependencyBrowserTest>>testHasPackageSelected (in category 'testing - metaclass') ----- testHasPackageSelected self deny: browser hasPackageSelected. browser packageListIndex: 1. self assert: browser hasPackageSelected. browser packageListIndex: 0. self deny: browser hasPackageSelected.! ----- Method: DependencyBrowserTest>>testSelectedClassOrMetaClass (in category 'testing - metaclass') ----- testSelectedClassOrMetaClass "Warning!! When Collections' dependencies change, this test may start to fail!!" self assert: browser selectedClassOrMetaClass isNil. browser packageListIndex: (browser packageList indexOf: #Collections). self assert: browser selectedClassOrMetaClass isNil. browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). self assert: browser selectedClassOrMetaClass isNil. browser classDepsIndex: (browser classDeps indexOf: #Scanner). self assert: browser selectedClassOrMetaClass isNil. browser classListIndex: (browser classList indexOf: #Symbol). self deny: browser selectedClassOrMetaClass isNil. self assert: browser selectedClassOrMetaClass == Symbol.! ----- Method: DependencyBrowserTest>>testSelectedMessageClassSideShowsSource (in category 'testing - message list') ----- testSelectedMessageClassSideShowsSource "Warning!! When Collections' dependencies change, this test may start to fail!!" browser packageListIndex: (browser packageList indexOf: #Kernel). browser packageDepsIndex: (browser packageDeps indexOf: #Collections). browser classDepsIndex: (browser classDeps indexOf: #'Array'). browser classListIndex: (browser classList indexOf: #'DateAndTime class'). browser messageListIndex: 1. self assert: browser selectedMessageName == #fromSeconds:. self assert: browser contents = (DateAndTime class sourceCodeAt: #fromSeconds:) ! ----- Method: DependencyBrowserTest>>testSelectedMessageName (in category 'testing - message list') ----- testSelectedMessageName "Warning!! When Collections' dependencies change, this test may start to fail!!" self assert: browser selectedMessageName isNil. browser packageListIndex: (browser packageList indexOf: #Collections). self assert: browser selectedMessageName isNil. browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). self assert: browser selectedMessageName isNil. browser classDepsIndex: (browser classDeps indexOf: #Scanner). self assert: browser selectedMessageName isNil. browser classListIndex: (browser classList indexOf: #Symbol). self assert: browser selectedMessageName isNil. browser messageListIndex: 1. self assert: browser selectedMessageName == #storeOn:. browser messageListIndex: 0. self assert: browser selectedMessageName isNil.! ----- Method: DependencyBrowserTest>>testSelectedMessageNameClassSide (in category 'testing - message list') ----- testSelectedMessageNameClassSide "Warning!! When Collections' dependencies change, this test may start to fail!!" self assert: browser selectedMessageName isNil. browser packageListIndex: (browser packageList indexOf: #Kernel). self assert: browser selectedMessageName isNil. browser packageDepsIndex: (browser packageDeps indexOf: #Collections). self assert: browser selectedMessageName isNil. browser classDepsIndex: (browser classDeps indexOf: #Array). self assert: browser selectedMessageName isNil. browser classListIndex: (browser classList indexOf: #'DateAndTime class'). self assert: browser selectedMessageName isNil. browser messageListIndex: 1. self assert: browser selectedMessageName == #fromSeconds:. ! TestCase subclass: #FileContentsBrowserTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: FileContentsBrowserTest>>expectedFailures (in category 'as yet unclassified') ----- expectedFailures ^ #(testChangeMessageCategoriesLeavesClassSelected) "See Mantis #7615"! ----- Method: FileContentsBrowserTest>>setUp (in category 'as yet unclassified') ----- setUp | fileout testCat package packageDict organizer | testCat := self class category. fileout := WriteStream on: (String new: 10000). SystemOrganization fileOutCategory: testCat on: fileout. packageDict := Dictionary new. browser := FileContentsBrowser new. organizer := SystemOrganizer defaultList: Array new. package := (FilePackage new fullName: testCat; fileInFrom: fileout readStream). packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName. (browser := FileContentsBrowser systemOrganizer: organizer) packages: packageDict.! ----- Method: FileContentsBrowserTest>>testChangeMessageCategoriesLeavesClassSelected (in category 'as yet unclassified') ----- testChangeMessageCategoriesLeavesClassSelected browser selectSystemCategory: browser systemCategoryList first. browser selectClassNamed: browser classList first. "This is a no-op." browser changeMessageCategories: browser classOrMetaClassOrganizer printString. self assert: browser selectedClassName = browser class name.! TestCase subclass: #FileList2ModalDialogsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-FileList'! !FileList2ModalDialogsTest commentStamp: '<historical>' prior: 0! TestRunner open! ----- Method: FileList2ModalDialogsTest>>testModalFileSelector (in category 'running') ----- testModalFileSelector | window fileList2 | window := FileList2 morphicViewFileSelector. window openCenteredInWorld. fileList2 := window valueOfProperty: #fileListModel. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedFile isNil. fileList2 okHit. self deny: fileList2 getSelectedFile isNil ! ----- Method: FileList2ModalDialogsTest>>testModalFileSelectorForSuffixes (in category 'running') ----- testModalFileSelectorForSuffixes | window fileList2 | window := FileList2 morphicViewFileSelectorForSuffixes: nil. window openCenteredInWorld. fileList2 := window valueOfProperty: #fileListModel. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedFile isNil. fileList2 okHit. self deny: fileList2 getSelectedFile isNil ! ----- Method: FileList2ModalDialogsTest>>testModalFolderSelector (in category 'running') ----- testModalFolderSelector | window fileList2 | window := FileList2 morphicViewFolderSelector. fileList2 := window model. window openInWorld: self currentWorld extent: 300 at 400. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. fileList2 okHit. self deny: fileList2 getSelectedDirectory withoutListWrapper isNil ! ----- Method: FileList2ModalDialogsTest>>testModalFolderSelectorForProjectLoad (in category 'running') ----- testModalFolderSelectorForProjectLoad | window fileList2 w | window := FileList2 morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false. fileList2 := window valueOfProperty: #FileList. w := self currentWorld. window position: w topLeft + (w extent - window extent // 2). window openInWorld: w. window delete. self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. fileList2 okHit. self deny: fileList2 getSelectedDirectory withoutListWrapper isNil ! TestCase subclass: #HierarchyBrowserTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: HierarchyBrowserTest>>setUp (in category 'as yet unclassified') ----- setUp browser := HierarchyBrowser new.! ----- Method: HierarchyBrowserTest>>testClassList (in category 'as yet unclassified') ----- testClassList | c displayedClasses hierarchy | browser initHierarchyForClass: browser class. c := browser class theNonMetaClass. displayedClasses := browser classList collect: [:each | each withoutLeadingBlanks ]. hierarchy := (c allSuperclasses reversed, {browser class}, c allSubclasses) collect: [ :each | each name ]. self assert: displayedClasses = hierarchy.! ----- Method: HierarchyBrowserTest>>testClassListIndex (in category 'as yet unclassified') ----- testClassListIndex | expectedCat | expectedCat := [:i | (Smalltalk at: (browser classList at: i) withoutLeadingBlanks asSymbol) category ]. browser initHierarchyForClass: browser class. self deny: browser classListIndex = 0. 1 to: 3 do: [:n | browser classListIndex: n. self assert: browser classListIndex = n. self assert: browser selectedSystemCategory = (expectedCat value: n)]! ----- Method: HierarchyBrowserTest>>testClassListSansWhitespace (in category 'as yet unclassified') ----- testClassListSansWhitespace | c displayedClasses hierarchy | browser initHierarchyForClass: browser class. c := browser class theNonMetaClass. displayedClasses := browser classList collect: [:each | each withoutLeadingBlanks ]. hierarchy := (c allSuperclasses reversed, {browser class}, c allSubclasses) collect: [ :each | each name ]. self assert: displayedClasses = hierarchy.! ----- Method: HierarchyBrowserTest>>testInitHierarchyForClass (in category 'as yet unclassified') ----- testInitHierarchyForClass | b | b := HierarchyBrowser new initHierarchyForClass: browser class. self assert: b selectedClassName = browser class name.! ----- Method: HierarchyBrowserTest>>testSelectClass (in category 'as yet unclassified') ----- testSelectClass browser initHierarchyForClass: browser class. browser selectClass: ProtoObject. self assert: browser selectedClass = ProtoObject. browser selectClass: CodeHolder. self assert: browser selectedClass = CodeHolder.! ----- Method: HierarchyBrowserTest>>testSelectedClassName (in category 'as yet unclassified') ----- testSelectedClassName browser initHierarchyForClass: browser class. self assert: browser selectedClassName = browser class name. browser classListIndex: 0. self assert: browser selectedClassName isNil.! TestCase subclass: #MessageNamesTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: MessageNamesTest>>setUp (in category 'as yet unclassified') ----- setUp browser := MessageNames openMessageNames.! ----- Method: MessageNamesTest>>tearDown (in category 'as yet unclassified') ----- tearDown browser topView ifNotNil: [:v | ToolBuilder default close: v].! ----- Method: MessageNamesTest>>testCannotUnselectCategory (in category 'as yet unclassified') ----- testCannotUnselectCategory | selectorList | browser searchString: 'cull'. browser selectorListIndex: 1. selectorList := browser selectorList copy. browser selectorListIndex: 0. self assert: selectorList = browser selectorList.! ----- Method: MessageNamesTest>>testOpenMessageNames (in category 'as yet unclassified') ----- testOpenMessageNames | b | b := MessageNames openMessageNames. [self assert: (b isKindOf: MessageNames)] ensure: [ToolBuilder default close: b topView].! ----- Method: MessageNamesTest>>testSearchString (in category 'as yet unclassified') ----- testSearchString | cCount cullCount cullCullCount | browser searchString: 'c'. cCount := browser selectorList size. browser searchString: 'cull:'. cullCount := browser selectorList size. self assert: cullCount < cCount. browser searchString: 'cull:cull:'. cullCullCount := browser selectorList size. self assert: cullCullCount < cullCount.! ----- Method: MessageNamesTest>>testSelectedClassOrMetaClass (in category 'as yet unclassified') ----- testSelectedClassOrMetaClass | firstClass | browser searchString: 'cull'. firstClass := browser messageList first actualClass. browser messageListIndex: 1. self assert: browser selectedClassOrMetaClass = firstClass. browser messageListIndex: 0. self assert: browser selectedClassOrMetaClass isNil. "And just to be sure:" browser messageListIndex: 1. self assert: browser selectedClassOrMetaClass = firstClass.! ----- Method: MessageNamesTest>>testSelectedMessageCategoryName (in category 'as yet unclassified') ----- testSelectedMessageCategoryName browser searchString: 'cull'. browser selectorListIndex: 1. browser messageListIndex: 1. self deny: browser selectedMessageCategoryName isNil. browser messageListIndex: 0. self assert: browser selectedMessageCategoryName isNil.! ----- Method: MessageNamesTest>>testSelection (in category 'as yet unclassified') ----- testSelection browser searchString: 'cull'. browser selectorListIndex: 1. browser messageListIndex: 1. self assert: (browser selection isKindOf: MethodReference). browser messageListIndex: 0. self assert: browser selection isNil.! TestCase subclass: #MessageSetTest instanceVariableNames: 'browser updates' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: MessageSetTest>>initialize (in category 'initialize-release') ----- initialize super initialize. "Contains the triggers sent by the model during its updates." updates := OrderedCollection new.! ----- Method: MessageSetTest>>setUp (in category 'running') ----- setUp browser := (MessageSet openMessageList: (SystemNavigation default allImplementorsOf: #browseAllImplementorsOf:) name: 'Test MessageSet' autoSelect: nil) model. browser addDependent: self.! ----- Method: MessageSetTest>>tearDown (in category 'running') ----- tearDown ToolBuilder default close: browser topView.! ----- Method: MessageSetTest>>testAutoSelectString (in category 'testing') ----- testAutoSelectString browser autoSelectString: 'browseAllImplementorsOf:'. self assert: browser autoSelectString = 'browseAllImplementorsOf:'. browser messageListIndex: 2. self assert: (updates includes: #autoSelect).! ----- Method: MessageSetTest>>testContents (in category 'testing') ----- testContents browser messageListIndex: 0. self assert: browser contents = ''. browser messageListIndex: 1. self deny: browser contents = ''. ! ----- Method: MessageSetTest>>testHasMessageSelected (in category 'testing') ----- testHasMessageSelected browser messageListIndex: 1. self assert: browser hasMessageSelected. browser messageListIndex: 0. self deny: browser hasMessageSelected. "And just to be sure:" browser messageListIndex: 1. self assert: browser hasMessageSelected.! ----- Method: MessageSetTest>>testRemoveMessageFromBrowser (in category 'testing') ----- testRemoveMessageFromBrowser | count sel | browser messageListIndex: 1. sel := browser selection. browser removeMessageFromBrowser. self deny: (browser messageList includes: sel) description: 'Method not removed'. browser messageListIndex: 0. count := browser messageList size. browser removeMessageFromBrowser. self assert: count = browser messageList size description: 'Some method was removed'.! ----- Method: MessageSetTest>>testSelectedClassOrMetaClass (in category 'testing') ----- testSelectedClassOrMetaClass | firstClass | firstClass := browser messageList first actualClass. browser messageListIndex: 1. self assert: browser selectedClassOrMetaClass = firstClass. browser messageListIndex: 0. self assert: browser selectedClassOrMetaClass isNil. "And just to be sure:" browser messageListIndex: 1. self assert: browser selectedClassOrMetaClass = firstClass.! ----- Method: MessageSetTest>>testSelectedMessageCategoryName (in category 'testing') ----- testSelectedMessageCategoryName | firstCat methodRef | methodRef := browser messageList first. firstCat := methodRef actualClass organization categoryOfElement: methodRef selector. browser messageListIndex: 1. self assert: browser selectedMessageCategoryName = firstCat. browser messageListIndex: 0. self assert: browser selectedMessageCategoryName isNil. "And just to be sure:" browser messageListIndex: 1. self assert: browser selectedMessageCategoryName = firstCat.! ----- Method: MessageSetTest>>testSelectedMessageName (in category 'testing') ----- testSelectedMessageName | firstSel | firstSel := browser messageList first selector. browser messageListIndex: 1. self assert: browser selectedMessageName = firstSel. browser messageListIndex: 0. self assert: browser selectedMessageName isNil. "And just to be sure:" browser messageListIndex: 1. self assert: browser selectedMessageName = firstSel.! ----- Method: MessageSetTest>>testSelection (in category 'testing') ----- testSelection | firstRef | firstRef := browser messageList first. browser messageListIndex: 1. self assert: browser selection = firstRef. browser messageListIndex: 0. self assert: browser selection isNil. "And just to be sure:" browser messageListIndex: 1. self assert: browser selection = firstRef.! ----- Method: MessageSetTest>>update: (in category 'private') ----- update: aSelector updates addLast: aSelector.! MessageSetTest subclass: #MessageTraceTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: MessageTraceTest>>setUp (in category 'as yet unclassified') ----- setUp browser := (MessageTrace openMessageList: (SystemNavigation default allImplementorsOf: #browseAllImplementorsOf:) name: 'Test MessageSet' autoSelect: nil) model. browser addDependent: self.! ----- Method: MessageTraceTest>>testRemoveMessageFromBrowser (in category 'as yet unclassified') ----- testRemoveMessageFromBrowser | count sel | browser messageListIndex: 1. sel := browser selection. browser removeMessageFromBrowser. self deny: (browser messageList includes: sel) description: 'Method not removed'. "In a MessageTrace, having an unselected message and then removing it means 'remove the first message'." browser messageListIndex: 0. count := browser messageList size. browser removeMessageFromBrowser. self assert: count - 1 = browser messageList size description: 'Method not removed'.! TestCase subclass: #OrderedCollectionInspectorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Inspector'! ----- Method: OrderedCollectionInspectorTest>>testUninitialized (in category 'as yet unclassified') ----- testUninitialized "Single stepping through a debugger can observe the object state after creation but before initiialisation." "Thus 'object size' may throw an axception for trying to do arithmetic on nil." "Modified OrderedCollectionInspector>>fieldList to call 'self objectSize' to handle this exception." "Original error reproduction: [ self halt. OrderedCollectionInspector openOn: (OrderedCollection new: 5) ] " "This should not throw an exception." (OrderedCollectionInspector openOn: OrderedCollection basicNew) delete.! TestCase subclass: #PackagePaneBrowserTest instanceVariableNames: 'browser' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Browser'! ----- Method: PackagePaneBrowserTest>>setUp (in category 'as yet unclassified') ----- setUp browser := PackagePaneBrowser new.! ----- Method: PackagePaneBrowserTest>>testClassList (in category 'as yet unclassified') ----- testClassList browser selectSystemCategory: browser class category. self assert: browser classList = (SystemOrganization listAtCategoryNamed: browser class category). browser selectSystemCategory: nil. self assert: browser classList isEmpty.! ----- Method: PackagePaneBrowserTest>>testPackageListIndex (in category 'as yet unclassified') ----- testPackageListIndex browser packageListIndex: 0. self assert: browser selectedClass isNil. browser selectCategoryForClass: browser class. "Clicking the selected package unselects the selected class." browser packageListIndex: browser packageListIndex. self assert: browser selectedClass isNil.! ----- Method: PackagePaneBrowserTest>>testSelectCategoryForClass (in category 'as yet unclassified') ----- testSelectCategoryForClass | pkgName | pkgName := browser class category copyUpTo: $-. browser selectCategoryForClass: browser class. self assert: browser selectedSystemCategory = browser class category. self assert: browser packageListIndex = (browser packageList indexOf: pkgName). browser selectSystemCategory: nil. self assert: browser classList isEmpty.! TestCase subclass: #WeakSetInspectorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-Inspector'! ----- Method: WeakSetInspectorTest>>testSymbolTableM6812 (in category 'testing') ----- testSymbolTableM6812 "this test is related to http://bugs.squeak.org/view.php?id=6812" | aWeakSet anInspector fieldSize | aWeakSet := (Symbol classPool at: #SymbolTable). anInspector := (ToolSet inspectorClassOf: aWeakSet) inspect: aWeakSet. fieldSize := anInspector fieldList size. Smalltalk garbageCollect. self assert: fieldSize = anInspector fieldList size. ! Object subclass: #DummyToolWorkingWithFileList instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-FileList'! !DummyToolWorkingWithFileList commentStamp: '<historical>' prior: 0! I'm a dummy class for testing that the registration of the tool to the FileList of actually happens. In the future the tests should cover that the class register when loaded in memory and unregister when unloaded.! ----- Method: DummyToolWorkingWithFileList class>>fileReaderServicesForFile:suffix: (in category 'class initialization') ----- fileReaderServicesForFile: fullName suffix: suffix ^ (suffix = 'kkk') ifTrue: [ self services] ifFalse: [#()] ! ----- Method: DummyToolWorkingWithFileList class>>initialize (in category 'class initialization') ----- initialize "self initialize" FileList registerFileReader: self ! ----- Method: DummyToolWorkingWithFileList class>>loadAFileForTheDummyTool: (in category 'class initialization') ----- loadAFileForTheDummyTool: aFileListOrAPath "attention. if the file list selects a file the argument will be a fullpath of the selected file else it will pass the filelist itself"! ----- Method: DummyToolWorkingWithFileList class>>serviceLoadAFilForDummyTool (in category 'class initialization') ----- serviceLoadAFilForDummyTool "Answer a service for opening the Dummy tool" ^ SimpleServiceEntry provider: self label: 'menu label' selector: #loadAFileForTheDummyTool: description: 'Menu label for dummy tool' buttonLabel: 'test'! ----- Method: DummyToolWorkingWithFileList class>>services (in category 'class initialization') ----- services ^ Array with: self serviceLoadAFilForDummyTool ! ----- Method: DummyToolWorkingWithFileList class>>unload (in category 'class initialization') ----- unload FileList unregisterFileReader: self ! ----- Method: DummyToolWorkingWithFileList class>>unregister (in category 'class initialization') ----- unregister FileList unregisterFileReader: self. ! ClassTestCase subclass: #FileListTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTests-FileList'! ----- Method: FileListTest>>checkIsServiceIsFromDummyTool: (in category 'private') ----- checkIsServiceIsFromDummyTool: service ^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList and: [ service label = 'menu label' and: [ (service instVarNamed: #selector) = #loadAFileForTheDummyTool: ] ]! ----- Method: FileListTest>>setUp (in category 'initialize') ----- setUp DummyToolWorkingWithFileList initialize.! ----- Method: FileListTest>>tearDown (in category 'initialize') ----- tearDown DummyToolWorkingWithFileList unregister.! ----- Method: FileListTest>>testAllRegisteredServices (in category 'test') ----- testAllRegisteredServices "(self selector: #testAllRegisteredServices) debug" "This should not throw an exception." FileList allRegisteredServices.! ----- Method: FileListTest>>testMenuReturned (in category 'test') ----- testMenuReturned "(self selector: #testToolRegistered) debug" self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! ----- Method: FileListTest>>testService (in category 'test') ----- testService "a stupid test to check that the class returns a service" "(self selector: #testService) debug" | service | service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'abab.kkk' suffix: 'kkk') first. self assert: (self checkIsServiceIsFromDummyTool: service). service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'zkk.gz' suffix: 'gz'). self assert: service isEmpty! ----- Method: FileListTest>>testServicesForFileEnding (in category 'test') ----- testServicesForFileEnding "(self selector: #testServicesForFileEnding) debug" self assert: (((FileList new directory: FileDirectory default; yourself) itemsForFile: 'aaa.kkk') anySatisfy: [ :ea | self checkIsServiceIsFromDummyTool: ea ]). ! ----- Method: FileListTest>>testToolRegistered (in category 'test') ----- testToolRegistered "(self selector: #testToolRegistered) debug" self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! ----- Method: FileListTest>>testToolRegisteredUsingInterface (in category 'test') ----- testToolRegisteredUsingInterface "(self selector: #testToolRegisteredUsingInterface) debug" self assert: (FileList isReaderNamedRegistered: #DummyToolWorkingWithFileList)!
More information about the Squeak-dev mailing list |