# HG changeset patch # User Claus Gittinger # Date 1517529251 -3600 # Node ID cf715db898dd250df4b3875ce4c0db2a5d43722d # Parent e26aace861c6372a18ab41d145453a7ce23068ae #UI_ENHANCEMENT by cg class: ResourceSelectionBrowser finally, some improvements to this ugly old beast added:15 methods comment/format in: #classSelected #postBuildWith: #postOpenWith: #rootOfClassCategories #treeViewClassHierarchyContents #updateResourceMethodList changed: #classSelectionUpdate: #listOfClasses #openOnSuperclass:andClass:andSelector:withResourceTypes: #resourceSelected #rootOfClassHierarchy #selectionOfClassPresentation #treeViewClassCategoryChildren #treeViewClassCategoryIcon category of: #openOnSuperclass:andClass:andSelector:withResourceTypes: #treeViewClassCategoryChildren #treeViewClassCategoryIcon #treeViewClassHierarchyContents #validateDoubleClick: class: ResourceSelectionBrowser class added: #title:onSuperclass:andClass:andSelector:withResourceTypes: removed: #treeViewClassHierarchyChildren #treeViewClassHierarchyContents #treeViewClassHierarchyIcon #treeViewClassHierarchyLabel comment/format in: #documentation #request:onSuperclass:andClass:andSelector:withResourceTypes: changed: #windowSpec class: ResourceSelectionBrowser::ResourceMethod added: #method diff -r e26aace861c6 -r cf715db898dd ResourceSelectionBrowser.st --- a/ResourceSelectionBrowser.st Thu Jan 25 21:35:49 2018 +0100 +++ b/ResourceSelectionBrowser.st Fri Feb 02 00:54:11 2018 +0100 @@ -1,3 +1,5 @@ +"{ Encoding: utf8 }" + " COPYRIGHT (c) 1997-1998 by eXept Software AG All Rights Reserved @@ -15,8 +17,9 @@ SelectionBrowser subclass:#ResourceSelectionBrowser instanceVariableNames:'resourceMethod resourceClass resourceSuperclass resourceTypes - allClasses classSelectionBlock' - classVariableNames:'ClassPresentation' + allClasses classSelectionBlock classFilter packageFilter + metaClassOnly existingOnly filter classPresentation' + classVariableNames:'LastClassPresentation' poolDictionaries:'' category:'Interface-Dialogs' ! @@ -58,6 +61,10 @@ resourceTypes allowed resource types allClasses list of the subclasses of resourceSuperclass classSelectionBlock by evaluating this block the class selection is done + classFilter if non-nil, given a class, has to return true for a class to be shown + packageFilter if non-nil, given a package, has to return true for a class to be shown + existingOnly if set, only classes with existing resources are shown (for load dialogs); + otherwise, empty classes are also shown (for save dialogs) [start with:] ResourceSelectionBrowser open @@ -70,117 +77,47 @@ !ResourceSelectionBrowser class methodsFor:'instance creation'! request:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes - "opens a ResourceSelectionBrowser; return a Message-object or nil." + "opens a ResourceSelectionBrowser; + return a Message-object (whoInfo) or nil." - ^ (self new - title: aTitle) - openOnSuperclass:aSuperclass - andClass:aClassOrClassName - andSelector:aSelector - withResourceTypes:resourceTypes + ^ (self + title:aTitle + onSuperclass:aSuperclass + andClass:aClassOrClassName andSelector:aSelector + withResourceTypes:resourceTypes + ) openAndLetUserChoose " ResourceSelectionBrowser request: 'Select a Resource Selector' onSuperclass: #ApplicationModel - andClassNamed: #MenuEditor - andSelector: #menuItemImage + andClass: MenuEditor andSelector: #menuItemImage withResourceTypes: #(image) " -! ! - -!ResourceSelectionBrowser class methodsFor:'callbacks-default'! - -treeViewClassHierarchyChildren - "returns the children for the contents (class) of aTreeItem as a block" - - "/ cg: tz's algorithm was very-very slow, - "/ (it enumerated classes hundreds of times, - "/ leading to a square runtime behavior - "/ - i.e. very slow scrolling ) - "/ Speed up things by caching facts while enumerating - "/ classes once only. - - |subclassesAndPrivateClassesPerClass| - - subclassesAndPrivateClassesPerClass := IdentityDictionary new. - - Smalltalk allClassesDo:[:cls | - |owner superclass info| - -"/ (owner := cls owningClass) notNil ifTrue:[ -"/ info := subclassesAndPrivateClassesPerClass at:owner ifAbsent:nil. -"/ info isNil ifTrue:[ -"/ subclassesAndPrivateClassesPerClass at:owner put:(info := Array with:IdentitySet new -"/ with:IdentitySet new). -"/ ]. -"/ (info at:2) add:cls -"/ ] ifFalse:[ - superclass := cls superclass. - superclass notNil ifTrue:[ - info := subclassesAndPrivateClassesPerClass at:superclass ifAbsent:nil. - info isNil ifTrue:[ - subclassesAndPrivateClassesPerClass at:superclass put:(info := Array with:IdentitySet new - with:IdentitySet new). - ]. - (info at:1) add:cls - ] -"/ ] - ]. - - ^ [:aTreeItem| - |classes itemClass info| - - classes := OrderedCollection new. - itemClass := aTreeItem contents. - info := subclassesAndPrivateClassesPerClass at:itemClass ifAbsent:nil. - info notNil ifTrue:[ - classes addAll:((info at:1) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]). - classes addAll:((info at:2) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]). - ]. - classes - ] ! -treeViewClassHierarchyContents - "returns the default contents of the root of the class tree list" - - ^ Object - -! - -treeViewClassHierarchyIcon - "returns the icon for aTreeItem as a block" - - ^[:aTreeItem| - |icon| +title:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes + "creates and returns a ResourceSelectionBrowser but does not open it. + To open, + send the returned browser an openAndLetUserChoose message, + which returns the selected resource method's info (whoInfo) or nil on cancel. + Use this to set additional filters before opening" - aTreeItem contents isClass ifTrue:[ - icon := self iconClass. - aTreeItem contents isPrivate ifTrue:[ - icon := self iconPrivateClass - ]. - icon - ] ifFalse:[ - self iconCategory - ] - ] - -! + ^ (self new + title: aTitle) + onSuperclass:aSuperclass + andClass:aClassOrClassName + andSelector:aSelector + withResourceTypes:resourceTypes -treeViewClassHierarchyLabel - "returns the label for aTreeItem as a block" - - ^[:aTreeItem| - |label superCls itemContents| - - itemContents := aTreeItem contents. - label := itemContents name. -"/ (itemContents isPrivate -"/ and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)]) -"/ ifTrue: [label := label, ' (', superCls name, ')']. - label - ] + " + (ResourceSelectionBrowser + title: 'Select a Resource Selector' + onSuperclass: #ApplicationModel + andClass: MenuEditor andSelector: #menuItemImage + withResourceTypes: #(image) + ) openAndLetUserChoose + " ! ! !ResourceSelectionBrowser class methodsFor:'image specs'! @@ -295,196 +232,256 @@ ^ - #(FullSpec - name: windowSpec - window: - (WindowSpec - label: 'Resource Selection Browser' - name: 'Resource Selection Browser' - min: (Point 400 300) - bounds: (Rectangle 12 22 612 372) - ) - component: - (SpecCollection - collection: ( - (VariableHorizontalPanelSpec - name: 'VariableHorizontalPanel' - layout: (LayoutFrame 0 0.0 0 0.0 0 1.0 -36 1.0) - component: - (SpecCollection - collection: ( - (ViewSpec - name: 'Box1' - component: - (SpecCollection - collection: ( - (HorizontalPanelViewSpec - name: 'HorizontalPanel2' - layout: (LayoutFrame 0 0 2 0 297 0 23 0) - horizontalLayout: leftSpace - verticalLayout: fit - horizontalSpace: 3 - verticalSpace: 3 - component: - (SpecCollection - collection: ( - (RadioButtonSpec - label: 'Categories' - name: 'ClassCategoriesRadioButton' - translateLabel: true - model: selectionOfClassPresentation - isTriggerOnDown: true - lampColor: (Color 0.0 0.0 0.0) - select: #'Class Categories' - extent: (Point 124 21) - ) - (RadioButtonSpec - label: 'Hierarchy' - name: 'ClassHierarchyRadioButton' - translateLabel: true - model: selectionOfClassPresentation - isTriggerOnDown: true - lampColor: (Color 0.0 0.0 0.0) - select: #'Class Hierarchy' - extent: (Point 145 21) - ) + #(FullSpec + name: windowSpec + uuid: 'fb378b3c-07aa-11e8-8563-b8f6b1108e05' + window: + (WindowSpec + label: 'Resource Selection Browser' + name: 'Resource Selection Browser' + uuid: 'f1361a68-0791-11e8-8563-b8f6b1108e05' + min: (Point 400 300) + bounds: (Rectangle 0 0 644 460) + ) + component: + (SpecCollection + collection: ( + (VariableHorizontalPanelSpec + name: 'VariableHorizontalPanel' + layout: (LayoutFrame 0 0.0 0 0.0 0 1.0 -36 1.0) + uuid: 'f1361c5c-0791-11e8-8563-b8f6b1108e05' + component: + (SpecCollection + collection: ( + (ViewSpec + name: 'Box1' + uuid: 'f1361df6-0791-11e8-8563-b8f6b1108e05' + component: + (SpecCollection + collection: ( + (HorizontalPanelViewSpec + name: 'HorizontalPanel2' + layout: (LayoutFrame 0 0 2 0 297 0 23 0) + uuid: 'f1361ebe-0791-11e8-8563-b8f6b1108e05' + horizontalLayout: leftSpace + verticalLayout: fit + horizontalSpace: 3 + verticalSpace: 3 + component: + (SpecCollection + collection: ( + (RadioButtonSpec + label: 'Flat' + name: 'RadioButton1' + uuid: 'f1362062-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + model: selectionOfClassPresentation + isTriggerOnDown: true + lampColor: (Color 0.0 0.0 0.0) + select: Flat + extent: (Point 80 21) + ) + (RadioButtonSpec + label: 'Categories' + name: 'ClassCategoriesRadioButton' + uuid: 'f1362062-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + model: selectionOfClassPresentation + isTriggerOnDown: true + lampColor: (Color 0.0 0.0 0.0) + select: #'Class Categories' + extent: (Point 124 21) + ) + (RadioButtonSpec + label: 'Hierarchy' + name: 'ClassHierarchyRadioButton' + uuid: 'f136233c-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + model: selectionOfClassPresentation + isTriggerOnDown: true + lampColor: (Color 0.0 0.0 0.0) + select: #'Class Hierarchy' + extent: (Point 145 21) ) - - ) - ) - (SelectionInTreeViewSpec - name: 'listOfClassHierarchyView' - layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0) - tabable: true - model: selectionOfClassHierarchy - hasHorizontalScrollBar: true - hasVerticalScrollBar: true - miniScrollerHorizontal: true - showDirectoryIndicatorForRoot: false - showDirectoryIndicator: true - valueChangeSelector: classSelected - hierarchicalList: rootOfClassHierarchy - validateDoubleClickSelector: validateDoubleClick: - contentsSelector: treeViewClassHierarchyContents - labelSelector: treeViewClassHierarchyLabel - childrenSelector: treeViewClassHierarchyChildren - iconSelector: treeViewClassHierarchyIcon - highlightMode: line - ) - (SelectionInTreeViewSpec - name: 'listOfClassCategoriesView' - layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0) - tabable: true - model: selectionOfClassCategories - hasHorizontalScrollBar: true - hasVerticalScrollBar: true - miniScrollerHorizontal: true - showRoot: false - showDirectoryIndicator: true - valueChangeSelector: classSelected - hierarchicalList: rootOfClassCategories - validateDoubleClickSelector: validateDoubleClick: - childrenSelector: treeViewClassCategoryChildren - iconSelector: treeViewClassCategoryIcon - highlightMode: line - ) - (InputFieldSpec - name: 'classNameInputField' - layout: (LayoutFrame 2 0.0 -22 1 -1 1.0 0 1) - tabable: true - model: classNameHolder - acceptOnLeave: true - acceptOnLostFocus: true - acceptOnPointerLeave: true - ) + ) + + ) + ) + (SequenceViewSpec + name: 'listOfClassesView' + layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0) + uuid: 'f13624d6-0791-11e8-8563-b8f6b1108e05' + tabable: true + model: indexOfSelectedClassInFlatList + hasHorizontalScrollBar: true + hasVerticalScrollBar: true + miniScrollerHorizontal: true + useIndex: true + sequenceList: listOfClassNames + ) + (SelectionInTreeViewSpec + name: 'listOfClassHierarchyView' + layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0) + uuid: 'f13624d6-0791-11e8-8563-b8f6b1108e05' + tabable: true + model: selectionOfClassHierarchy + hasHorizontalScrollBar: true + hasVerticalScrollBar: true + miniScrollerHorizontal: true + showDirectoryIndicatorForRoot: false + showDirectoryIndicator: true + valueChangeSelector: classSelected + hierarchicalList: rootOfClassHierarchy + validateDoubleClickSelector: validateDoubleClick: + contentsSelector: treeViewClassHierarchyContents + labelSelector: treeViewClassHierarchyLabel + childrenSelector: treeViewClassHierarchyChildren + iconSelector: treeViewClassHierarchyIcon + highlightMode: line + ) + (SelectionInTreeViewSpec + name: 'listOfClassCategoriesView' + layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0) + uuid: 'f13627ba-0791-11e8-8563-b8f6b1108e05' + tabable: true + model: selectionOfClassCategories + hasHorizontalScrollBar: true + hasVerticalScrollBar: true + miniScrollerHorizontal: true + showRoot: false + showDirectoryIndicator: true + valueChangeSelector: classSelected + hierarchicalList: rootOfClassCategories + validateDoubleClickSelector: validateDoubleClick: + childrenSelector: treeViewClassCategoryChildren + iconSelector: treeViewClassCategoryIcon + highlightMode: line + ) + (InputFieldSpec + name: 'classNameInputField' + layout: (LayoutFrame 2 0.0 -22 1 -1 1.0 0 1) + uuid: 'f1362922-0791-11e8-8563-b8f6b1108e05' + tabable: true + model: classNameHolder + acceptOnLeave: true + acceptOnLostFocus: true + acceptOnPointerLeave: true ) - - ) - ) - (ViewSpec - name: 'Box2' - component: - (SpecCollection - collection: ( - (DataSetSpec - name: 'resourcesDataSetView' - layout: (LayoutFrame 2 0.0 2 0.0 -2 1.0 -24 1.0) - model: selectionOfResourceMethod - hasHorizontalScrollBar: true - hasVerticalScrollBar: true - miniScrollerHorizontal: true - rowClassName: 'ResourceSelectionBrowser::Row' - dataList: listOfResourceMethods - useIndex: false - has3Dsepartors: true - has3Dseparators: true - doubleClickSelector: resourceDoubleClicked - columnHolder: resourceMethodColumns - valueChangeSelector: resourceSelected - verticalSpacing: 1 - ) - (InputFieldSpec - name: 'selectorInputField' - layout: (LayoutFrame 2 0.0 -22 1 -2 1.0 0 1) - tabable: true - model: resourceSelectorHolder - acceptOnLeave: true - acceptOnLostFocus: true - acceptOnPointerLeave: true - ) + ) + + ) + ) + (ViewSpec + name: 'Box2' + uuid: 'f1362aee-0791-11e8-8563-b8f6b1108e05' + component: + (SpecCollection + collection: ( + (VariableVerticalPanelSpec + name: 'ResourcePanel' + layout: (LayoutFrame 2 0.0 2 0.0 -2 1.0 -24 1.0) + uuid: '51c4b91e-07a8-11e8-8563-b8f6b1108e05' + component: + (SpecCollection + collection: ( + (DataSetSpec + name: 'resourcesDataSetView' + uuid: 'f1362bac-0791-11e8-8563-b8f6b1108e05' + model: selectionOfResourceMethod + hasHorizontalScrollBar: true + hasVerticalScrollBar: true + miniScrollerHorizontal: true + rowClassName: 'ResourceSelectionBrowser::Row' + dataList: listOfResourceMethods + useIndex: false + has3Dseparators: true + doubleClickSelector: resourceDoubleClicked + columnHolder: resourceMethodColumns + valueChangeSelector: resourceSelected + verticalSpacing: 1 + ) + (ArbitraryComponentSpec + name: 'ImageView' + uuid: '51c4bd9c-07a8-11e8-8563-b8f6b1108e05' + hasBorder: false + component: ImageView + ) + ) + + ) + handles: (Any 0.98999999999999999 1.0) ) - - ) - ) + (InputFieldSpec + name: 'selectorInputField' + layout: (LayoutFrame 2 0.0 -22 1 -2 1.0 0 1) + uuid: 'f1362db4-0791-11e8-8563-b8f6b1108e05' + tabable: true + model: resourceSelectorHolder + acceptOnLeave: true + acceptOnLostFocus: true + acceptOnPointerLeave: true + ) + ) + + ) ) - - ) - handles: (Any 0.5 1.0) - ) - (HorizontalPanelViewSpec - name: 'ButtonPanel' - layout: (LayoutFrame 2 0.0 -30 1 -2 1.0 -4 1.0) - horizontalLayout: fit - verticalLayout: fit - reverseOrderIfOKAtLeft: true - component: - (SpecCollection - collection: ( - (ActionButtonSpec - label: 'Help' - name: 'HelpButton' - activeHelpKey: dss - model: openHTMLDocument: - initiallyDisabled: true - enableChannel: helpEnabled - actionValue: 'tools/uipainter/ResourceSelectionBrowser.html' - extent: (Point 196 26) - ) - (ActionButtonSpec - label: 'Cancel' - name: 'cancelButton' - activeHelpKey: commitCancel - tabable: true - model: cancel - extent: (Point 197 26) - ) - (ActionButtonSpec - label: 'OK' - name: 'okButton' - activeHelpKey: commitOK - tabable: true - model: accept - isDefault: true - extent: (Point 197 26) - ) + ) + + ) + handles: (Any 0.5 1.0) + ) + (HorizontalPanelViewSpec + name: 'ButtonPanel' + layout: (LayoutFrame 2 0.0 -30 1 -18 1.0 -4 1.0) + uuid: 'f1362f3a-0791-11e8-8563-b8f6b1108e05' + horizontalLayout: fit + verticalLayout: fit + reverseOrderIfOKAtLeft: true + component: + (SpecCollection + collection: ( + (ActionButtonSpec + label: 'Help' + name: 'HelpButton' + activeHelpKey: dss + uuid: 'f136303e-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + model: openHTMLDocument: + initiallyDisabled: true + enableChannel: helpEnabled + actionValue: 'tools/uipainter/ResourceSelectionBrowser.html' + extent: (Point 204 26) ) - - ) - ) + (ActionButtonSpec + label: 'Cancel' + name: 'cancelButton' + activeHelpKey: commitCancel + uuid: 'f13631ba-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + tabable: true + model: cancel + extent: (Point 204 26) + ) + (ActionButtonSpec + label: 'OK' + name: 'okButton' + activeHelpKey: commitOK + uuid: 'f1363336-0791-11e8-8563-b8f6b1108e05' + translateLabel: true + tabable: true + model: accept + isDefault: true + extent: (Point 204 26) + ) + ) + + ) + keepSpaceForOSXResizeHandleH: true ) - - ) - ) + ) + + ) + ) ! ! !ResourceSelectionBrowser class methodsFor:'list specs'! @@ -525,6 +522,32 @@ ) ! ! +!ResourceSelectionBrowser methodsFor:'accessing'! + +classFilter:aBlock + "aBlock to return true/false, given a class. + With false, it is not shown in the tree" + + classFilter := aBlock. +! + +existingOnly:something + existingOnly := something. +! + +metaClassOnly:aBoolean + "force selection to be limited to the metaclass" + + metaClassOnly := aBoolean. +! + +packageFilter:aBlock + "aBlock to return true/false, given a packageID. + With false, the class is not shown in the tree" + + packageFilter := aBlock. +! ! + !ResourceSelectionBrowser methodsFor:'aspects'! classNameHolder @@ -545,6 +568,35 @@ ^true ! +indexOfSelectedClassInFlatList + |holder| + + (holder := builder bindingAt:#indexOfSelectedClassInFlatList) isNil ifTrue:[ + builder aspectAt:#indexOfSelectedClassInFlatList put:(holder := nil asValue). + holder onChangeEvaluate:[ + |clsName| + + clsName := self listOfClassNames at:holder value ifAbsent:nil. + clsName notNil ifTrue:[ + classSelectionBlock value:clsName + ]. + ]. + ]. + ^ holder +! + +listOfClassNames + "returns the value holder for the flat class list" + + |holder| + + + (holder := builder bindingAt:#listOfClassNames) isNil ifTrue:[ + builder aspectAt:#listOfClassNames put: (holder := List new). + ]. + ^ holder +! + listOfResourceMethods "returns the value holder for the list of the resource methods" @@ -578,12 +630,11 @@ |holder| (holder := builder bindingAt:#rootOfClassCategories) isNil ifTrue:[ - ClassPresentation = #'Class Categories' ifTrue: [ - builder aspectAt:#rootOfClassCategories put: (holder := TreeItem name: 'Categories')]. + classPresentation = #'Class Categories' ifTrue: [ + builder aspectAt:#rootOfClassCategories put: (holder := TreeItem name: 'Categories') + ]. ]. ^ holder - - ! rootOfClassHierarchy @@ -593,12 +644,11 @@ (holder := builder bindingAt:#rootOfClassHierarchy) isNil ifTrue:[ - ClassPresentation = #'Class Hierarchy' ifTrue: [ - builder aspectAt:#rootOfClassHierarchy put: (holder := TreeItem new)] + classPresentation = #'Class Hierarchy' ifTrue: [ + builder aspectAt:#rootOfClassHierarchy put: (holder := TreeItem new) + ] ]. ^ holder - - ! selectionOfClassCategories @@ -622,29 +672,17 @@ ! selectionOfClassPresentation - "returns the value holder for the selected class presentation" + "returns the value holder for the selected class presentation + (Flat, Hierarchy or Category)" |holder| (holder := builder bindingAt:#selectionOfClassPresentation) isNil ifTrue:[ - builder aspectAt:#selectionOfClassPresentation put:(holder := RadioButtonGroup with: (ClassPresentation := ClassPresentation ? #'Class Categories')). - holder onChangeEvaluate: - [ - |hv comp newRoot| + builder + aspectAt:#selectionOfClassPresentation + put:(holder := RadioButtonGroup with: (classPresentation := classPresentation ? LastClassPresentation ? #'Class Categories')). - hv := holder value. - ClassPresentation := hv. - hv = #'Class Hierarchy' ifTrue:[ - comp := builder componentAt: #listOfClassHierarchyView. - newRoot := self rootOfClassHierarchy. - ] ifFalse: [ - comp := builder componentAt: #listOfClassCategoriesView. - newRoot := self rootOfClassCategories. - ]. - comp root:newRoot. - comp raise. - classSelectionBlock value: self classNameHolder value - ] + holder onChangeEvaluate:[self classPresentationChanged ]. ]. ^ holder ! @@ -675,91 +713,203 @@ ^ self resourceSelectorHolder ! ! -!ResourceSelectionBrowser methodsFor:'callbacks-class list'! - -treeViewClassCategoryChildren - "returns the children for the contents (class) of aTreeItem as a block" +!ResourceSelectionBrowser methodsFor:'callbacks-user'! - "/ cg: tz's algorithm was very-very slow, - "/ (it enumerated classes hundreds of times, - "/ leading to a square runtime behavior - "/ - i.e. very slow scrolling ) - "/ Speed up things by caching facts while enumerating - "/ classes once only. +classPresentationChanged + "returns the value holder for the selected class presentation + (Flat, Hierarchy or Category)" - |topClass childrenPerCategory privateClasses| + |comp newRoot| - topClass := self treeViewClassHierarchyContents. - privateClasses := IdentitySet new. + classPresentation := LastClassPresentation := self selectionOfClassPresentation value. - childrenPerCategory := Dictionary new. - - topClass withAllSubclassesDo:[:cls | - |cat set| - - cls isPrivate ifFalse:[ - cat := cls category. - cat notNil ifTrue:[ - set := childrenPerCategory at:cat ifAbsent:nil. - set isNil ifTrue:[ - childrenPerCategory at:cat put:(set := IdentitySet new). - ]. - set add:cls - ]. - ] ifTrue:[ - privateClasses add:cls - ] + classPresentation == #'Flat' ifTrue:[ + self listOfClassNames isEmpty ifTrue:[ self updateListOfClasses ]. + comp := builder componentAt: #listOfClassesView. + ] ifFalse:[ + classPresentation == #'Class Hierarchy' ifTrue:[ + comp := builder componentAt: #listOfClassHierarchyView. + newRoot := self rootOfClassHierarchy. + ] ifFalse: [ + comp := builder componentAt: #listOfClassCategoriesView. + newRoot := self rootOfClassCategories. + ]. + comp root:newRoot. ]. - ^ [:aTreeItem| - |cont children initialContents setOfCategories itemCategory setOfClasses| + comp raise; requestFocus. + classSelectionBlock value:(self classNameHolder value) +! + +classSelected + "after a class selection, read the allowed resource methods of the selected class" + + |sel className| + + classPresentation = #'Class Hierarchy' +"/ ifTrue: [sel := self selectionOfClassHierarchy value] + ifFalse: [sel := self selectionOfClassCategories value]. + + resourceClass := nil. + sel notNil ifTrue:[ + sel contents ~~ #Category ifTrue:[ + className := sel name. + resourceClass := Smalltalk classNamed:className. + ] + ]. + self updateResourceMethodList. +! + +classSelectionUpdate:clsPattern + "called when a new class is selected AND when switching presentation modes" + + |foundClass classes| + + "/ because this is also called for presentation switch, + "/ we cannot tune it this way... + "/ (self classNameHolder value = clsPattern) ifTrue:[ + "/ resourceClass notNil ifTrue:[ + "/ resourceClass name = clsPattern ifTrue:[ + "/ ^ self + "/ ]. + "/ ]. + "/ ]. - (cont := aTreeItem contents) isBehavior ifTrue:[ - children := privateClasses select:[:cls | cls owningClass == aTreeItem contents]. - children := children asSortedCollection: [:c1 :c2| c1 name <= c2 name]. - "/ children := children collect: [:child| TreeItem name: child name , ' (', child superclass name, ')' contents: child] - children := children collect: [:child| TreeItem name:(child name) contents: child] - ] ifFalse:[ - cont size == 0 ifTrue:[ - setOfCategories := childrenPerCategory keys. - children := setOfCategories asSortedCollection. - children := children collect: [:nm | TreeItem name:nm contents:#Category] - ] ifFalse:[ - cont == #Category ifTrue:[ - itemCategory := aTreeItem name. - setOfClasses := childrenPerCategory at:itemCategory ifAbsent:[Set new]. - children := setOfClasses asOrderedCollection sort:[:c1 :c2 | c1 name <= c2 name]. - children := children collect:[:child | TreeItem name:child name contents:child]. - ] ifFalse:[ - "/ huh ? - children := OrderedCollection new. - ] + clsPattern notNil ifTrue:[ + foundClass := Smalltalk classNamed:clsPattern. + ]. + (foundClass isClass not or:[foundClass name ~= clsPattern]) + ifTrue: [ + classes := allClasses select: [:cls| cls name size >= clsPattern size]. + 1 to: clsPattern size do: [:i| + classes := classes select: [:cls| (cls name at: i) == (clsPattern at: i)]. + ]. + foundClass := classes at: 1 ifAbsent:[]. + ]. + + foundClass notNil ifTrue: [ + foundClass := foundClass autoload. + resourceClass := foundClass. + + classPresentation = #'Flat' ifTrue: [ + |index| + + index := self listOfClassNames indexOf:resourceClass name. + self indexOfSelectedClassInFlatList value:index. + ] ifFalse: [ + classPresentation = #'Class Hierarchy' ifTrue: [ + |searchArgs nonSuperclasses hierItem| + + false "foundClass isPrivate" + ifFalse: [searchArgs := foundClass withAllSuperclasses reversed] + ifTrue: [searchArgs := foundClass owningClass withAllSuperclasses reversed. + searchArgs add: foundClass]. + (nonSuperclasses := self treeViewClassHierarchyContents allSuperclasses) notNil + ifTrue: [searchArgs := searchArgs reject: [:cls| nonSuperclasses includes: cls]]. + + hierItem := self rootOfClassHierarchy detectChild:[:child :arg| child contents == arg] arguments:searchArgs. + hierItem notNil ifTrue:[ + self selectionOfClassHierarchy value:hierItem. + ]. + ] ifFalse: [ + |searchArgs hierItem| + + false "foundClass isPrivate" + ifTrue: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass owningClass name with: foundClass name] + ifFalse: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass name]. + + hierItem := self rootOfClassCategories detectChild:[:child :arg| (child name upTo: $ ) = arg] arguments:searchArgs. + hierItem notNil ifTrue:[ + self selectionOfClassCategories value: hierItem. + ]. ]. ]. - children + ]. + + self classNameHolder value: clsPattern. + self updateResourceMethodList. +! + +resourceDoubleClicked + "after a double click on resource method, accept it and close" + + accept value: true. + self closeRequest +! + +resourceSelected + "after a click on a resource method, set its selector into the field" + + |selectedMethodInfo mthd| + + selectedMethodInfo := self selectionOfResourceMethod value. + selectedMethodInfo notNil ifTrue: [ + self resourceSelectorHolder value:(selectedMethodInfo selector). + mthd := selectedMethodInfo method. + (mthd hasResource:#image) ifTrue:[ + (builder componentAt:#ImageView) + image:(mthd valueWithReceiver:nil arguments:#()) + ]. ] +! - "Modified: / 22-08-2012 / 19:44:59 / cg" +updateListOfClasses + |names| + + classPresentation = #'Flat' ifTrue: [ + self listOfClassNames isEmpty ifTrue:[ + names := (Smalltalk allClasses asOrderedCollection sortBySelector:#name) + select:[:cls | self filterClass:cls] + thenCollect:[:cls | cls name]. + self listOfClassNames addAll:names. + ] + ] ! -treeViewClassCategoryIcon - "returns the icon for aTreeItem as a block" +updateResourceMethodList + "read the allowed resource methods of the selected class" + + |class className item| + + (class := resourceClass) isNil ifTrue:[ + classPresentation = #'Class Hierarchy' + ifTrue: [item := self selectionOfClassHierarchy value ] + ifFalse: [item := self selectionOfClassCategories value ]. - ^self class treeViewClassHierarchyIcon - - -! + item notNil ifTrue:[ + item contents ~~ #Category ifTrue:[ + className := item name. + class := Smalltalk at:className asSymbol. + ] + ]. + ] ifFalse:[ + class := resourceClass + ]. -treeViewClassHierarchyContents - "returns the contents of the root of the class tree list" + class isNil ifTrue: [ + self listOfResourceMethods contents:#(). + ^self + ]. - |cls| + className := class name."/class theNonMetaclass name + + self withWaitCursorDo:[ + |newContents| + + resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes]. - resourceSuperclass notNil ifTrue:[ - cls := Smalltalk classNamed: resourceSuperclass. - ]. - cls notNil ifTrue:[^ cls]. - ^ self class treeViewClassHierarchyContents + self classNameHolder value: className. + self class lastSelection: className. + + newContents := class theMetaclass methodDictionary asOrderedCollection + select:[:m | resourceTypes includes: m resourceType]. + + newContents := newContents sort:[:m1 :m2 | m1 selector < m2 selector]. + newContents := newContents collect:[:m| (ResourceMethod new method:m)]. + + self listOfResourceMethods contents:newContents + . + ] ! validateDoubleClick: aTreeItem @@ -774,133 +924,24 @@ ! ! -!ResourceSelectionBrowser methodsFor:'callbacks-user'! - -classSelected - "after a class selection, read the allowed resource methods of the selected class" - - |sel| - - ClassPresentation = #'Class Hierarchy' -"/ ifTrue: [sel := self selectionOfClassHierarchy value] - ifFalse: [sel := self selectionOfClassCategories value]. - - sel notNil ifTrue:[ - resourceClass := sel. - ]. - self updateResourceMethodList. -! - -classSelectionUpdate:clsPattern - |foundClass classes| +!ResourceSelectionBrowser methodsFor:'initialization'! - clsPattern notNil ifTrue:[ - foundClass := Smalltalk at:(clsPattern printString asSymbol). - ]. - (foundClass isClass not or:[foundClass name ~= clsPattern]) - ifTrue: [ - classes := allClasses select: [:cls| cls name size >= clsPattern size]. - 1 to: clsPattern size do: [:i| - classes := classes select: [:cls| (cls name at: i) == (clsPattern at: i)]. - ]. - foundClass := classes at: 1 ifAbsent:[]. - ]. - - foundClass notNil ifTrue: [ - foundClass := foundClass autoload. - resourceClass := foundClass. - - ClassPresentation = #'Class Hierarchy' ifTrue: [ - |searchArgs nonSuperclasses hierItem| - - false "foundClass isPrivate" - ifFalse: [searchArgs := foundClass withAllSuperclasses reversed] - ifTrue: [searchArgs := foundClass owningClass withAllSuperclasses reversed. - searchArgs add: foundClass]. - (nonSuperclasses := self treeViewClassHierarchyContents allSuperclasses) notNil - ifTrue: [searchArgs := searchArgs reject: [:cls| nonSuperclasses includes: cls]]. - - hierItem := self rootOfClassHierarchy detectChild:[:child :arg| child contents == arg] arguments:searchArgs. - hierItem notNil ifTrue:[ - self selectionOfClassHierarchy value:hierItem. - ]. - ] ifFalse: [ - |searchArgs hierItem| - - false "foundClass isPrivate" - ifTrue: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass owningClass name with: foundClass name] - ifFalse: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass name]. +initialize + "Invoked when a new instance is created." - hierItem := self rootOfClassCategories detectChild:[:child :arg| (child name upTo: $ ) = arg] arguments:searchArgs. - hierItem notNil ifTrue:[ - self selectionOfClassCategories value: hierItem. - ]. - ]. - ]. - self classNameHolder value: clsPattern. - self updateResourceMethodList. -! - -resourceDoubleClicked - "after a double click on resource method, accept it and close" - - accept value: true. - self closeRequest -! - -resourceSelected - "after a click on a resource method, set its selector into the field" - - self selectionOfResourceMethod value notNil - ifTrue: [self resourceSelectorHolder value: self selectionOfResourceMethod value selector] -! - -updateResourceMethodList - "read the allowed resource methods of the selected class" - - |class className item| + metaClassOnly := true. + existingOnly := false. - (class := resourceClass) isNil ifTrue:[ - ClassPresentation = #'Class Hierarchy' - ifTrue: [item := self selectionOfClassHierarchy value ] - ifFalse: [item := self selectionOfClassCategories value ]. - - item notNil ifTrue:[ - className := item name. - class := Smalltalk at:className asSymbol - ]. - ]. - - class isNil ifTrue: [^self]. - - className := class name."/class theNonMetaclass name - - self withWaitCursorDo:[ - |newContents| - - resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes]. - - self classNameHolder value: className. - self class lastSelection: className. - - newContents := class class methodDictionary asOrderedCollection - select: [:m | m resources notNil - and: [resourceTypes includes: m resourceType] - ]. - newContents := newContents sort:[:m1 :m2 | m1 selector < m2 selector]. - newContents := newContents collect:[:m| (ResourceMethod new method:m)]. - - self listOfResourceMethods contents:newContents - . - ] + super initialize. ! ! !ResourceSelectionBrowser methodsFor:'instance creation'! -openOnSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes - "opens a ResourceSelectionBrowser; return a Message-object or nil" +onSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes + "create - but do not yet open + a ResourceSelectionBrowser" - |selectedClass enteredClassName className cls| + |cls| resourceMethod := aSelector. resourceTypes := aResourceTypes. @@ -919,6 +960,16 @@ ] ]. self resourceSelectorHolder value:(aSelector ? ''). +! ! + +!ResourceSelectionBrowser methodsFor:'startup & release'! + +openAndLetUserChoose + "opens the previously configured receiver; + return a Message-object or nil" + + |selectedClass enteredClassName className cls| + self open. (selectedClass := self selectionOfClassHierarchy value) isNil ifTrue:[ @@ -947,16 +998,34 @@ ^ nil "Modified: / 22.4.1998 / 14:51:03 / cg" -! ! +! + +openOnSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes + "opens a ResourceSelectionBrowser; return a Message-object or nil" -!ResourceSelectionBrowser methodsFor:'startup & release'! + self + onSuperclass: aSuperclassOrSymbol + andClass:aClassOrClassName andSelector: aSelector + withResourceTypes: aResourceTypes. + + self openAndLetUserChoose +! postBuildWith:aBuilder "after building and before opening, create a class selection block, an entry completion block for the class name field" |classSelection classNameInputField| - + + (resourceTypes notNil and:[(resourceTypes includesAny:#(image programImage))]) ifTrue:[ + (builder componentAt: #resourcesDataSetView) + origin:0.0@0.0 extent:(1.0 @ 0.7). + (builder componentAt: #ImageView) + origin:0.0@0.7 extent:(1.0 @ 0.3); beVisible. + (builder componentAt: #ResourcePanel) + resizeSubviews; sizeChanged:nil. + ]. + allClasses := self treeViewClassHierarchyContents withAllSubclasses reject: [:cls| cls isPrivate]. classSelection := resourceClass isNil ifTrue:[nil] ifFalse:[resourceClass name]. @@ -978,7 +1047,10 @@ classNameInputField contents:what first. (what at:2) size ~~ 1 ifTrue:[ classNameInputField device beepInEditor - ] + ]. + (Smalltalk classNamed:(what at:1)) notNil ifTrue:[ + self classNameHolder value:(what at:1) + ]. "/ |what oldClassName| "/ oldClassName := classNameInputField contents. "/ what := Smalltalk classnameCompletion: value withoutSpaces. @@ -988,7 +1060,7 @@ ]. classSelectionBlock value: self classNameHolder value. - self updateResourceMethodList. + "/ self updateResourceMethodList. -- will be done automatically via change self selectionOfResourceMethod value: (self listOfResourceMethods detect: [:m| m selector == resourceMethod] ifNone: nil). ^super postBuildWith:aBuilder @@ -997,12 +1069,213 @@ postOpenWith:aBuilder "after opening and if turned on make hierarchy view visible" - ClassPresentation = #'Class Hierarchy' - ifTrue: [(builder componentAt: #listOfClassHierarchyView) raise]. + classPresentation = #'Class Hierarchy' ifTrue: [ + (builder componentAt: #listOfClassHierarchyView) raise + ]. + classPresentation = #'Flat' ifTrue: [ + self updateListOfClasses. + (builder componentAt: #listOfClassesView) raise + ]. super postOpenWith:aBuilder ! ! +!ResourceSelectionBrowser methodsFor:'tree building - category'! + +filterClass:cls + "true if cls is to be shown" + + classFilter notNil ifTrue:[ + (classFilter value:cls) ifFalse:[^ false]. + ]. + packageFilter notNil ifTrue:[ + (packageFilter value:cls package) ifFalse:[^ false]. + ]. + existingOnly == true ifTrue:[ + ^ cls theMetaclass methodDictionary + contains:[:m | + resourceTypes includes:m resourceType + ]. + ]. + ^ true +! + +treeViewClassCategoryChildren + "returns the children for the contents (class) of aTreeItem as a block" + + "/ cg: tz's algorithm was very-very slow, + "/ (it enumerated classes hundreds of times, + "/ leading to a square runtime behavior + "/ - i.e. very slow scrolling ) + "/ Speed up things by caching facts while enumerating + "/ classes once only. + + |topClass childrenPerCategory privateClasses| + + topClass := self treeViewClassHierarchyContents. + privateClasses := IdentitySet new. + + childrenPerCategory := Dictionary new. + + "/ collect all classes to be inserted into the tree(s) + topClass withAllSubclassesDo:[:cls | + |shown cat set| + + (self filterClass:cls) ifTrue:[ + cls isPrivate ifFalse:[ + cat := cls category. + cat notNil ifTrue:[ + (childrenPerCategory at:cat ifAbsentPut:[Set new]) add:cls + ]. + ] ifTrue:[ + privateClasses add:cls + ] + ]. + ]. + + "/ need the owningclasses in the tree + privateClasses do:[:each | + |owner| + + owner := each owningClass. + (childrenPerCategory at:(owner category) ifAbsentPut:[Set new]) add:owner + ]. + + ^ [:aTreeItem| + |cont children initialContents setOfCategories itemCategory setOfClasses| + + (cont := aTreeItem contents) isBehavior ifTrue:[ + children := privateClasses select:[:cls | cls owningClass == aTreeItem contents]. + children := children select:[:cls | self filterClass:cls]. + children := children asSortedCollection: [:c1 :c2| c1 name <= c2 name]. + "/ children := children collect: [:child| TreeItem name: child name , ' (', child superclass name, ')' contents: child] + children := children collect: [:child| TreeItem name:(child name) contents: child] + ] ifFalse:[ + cont size == 0 ifTrue:[ + setOfCategories := childrenPerCategory keys. + children := setOfCategories asSortedCollection. + children := children collect: [:nm | TreeItem name:nm contents:#Category] + ] ifFalse:[ + cont == #Category ifTrue:[ + itemCategory := aTreeItem name. + setOfClasses := childrenPerCategory at:itemCategory ifAbsent:[Set new]. + setOfClasses := setOfClasses select:[:cls | self filterClass:cls]. + children := setOfClasses asOrderedCollection sort:[:c1 :c2 | c1 name <= c2 name]. + children := children collect:[:child | TreeItem name:child name contents:child]. + ] ifFalse:[ + "/ huh ? + children := OrderedCollection new. + ] + ]. + ]. + children + ] + + "Modified: / 22-08-2012 / 19:44:59 / cg" +! + +treeViewClassCategoryIcon + "returns the icon for aTreeItem as a block" + + ^self treeViewClassHierarchyIcon +! ! + +!ResourceSelectionBrowser methodsFor:'tree building - hierarchy'! + +treeViewClassHierarchyChildren + "returns the children for the contents (class) of aTreeItem as a block" + + "/ cg: tz's algorithm was very-very slow, + "/ (it enumerated classes hundreds of times, + "/ leading to a square runtime behavior + "/ - i.e. very slow scrolling ) + "/ Speed up things by caching facts while enumerating + "/ classes once only. + + |subclassesAndPrivateClassesPerClass classesWithResourceOrResourceInAnySubclass| + + subclassesAndPrivateClassesPerClass := IdentityDictionary new. + classesWithResourceOrResourceInAnySubclass := IdentitySet new. + + Smalltalk allClassesDo:[:cls | + |owner superclass info| + + superclass := cls superclass. + superclass notNil ifTrue:[ + info := subclassesAndPrivateClassesPerClass at:superclass ifAbsent:nil. + info isNil ifTrue:[ + subclassesAndPrivateClassesPerClass + at:superclass + put:(info := {IdentitySet new. IdentitySet new} ). + ]. + (info at:1) add:cls + ]. + (self filterClass:cls) ifTrue:[ + cls withAllSuperclassesDo:[:each | + classesWithResourceOrResourceInAnySubclass add:each + ]. + ]. + ]. + + ^ [:aTreeItem| + |classes itemClass info| + + classes := OrderedCollection new. + itemClass := aTreeItem contents. + info := subclassesAndPrivateClassesPerClass at:itemClass ifAbsent:nil. + info notNil ifTrue:[ + classes addAll:((info at:1) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]). + classes addAll:((info at:2) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]). + ]. + classes select:[:cls | classesWithResourceOrResourceInAnySubclass includes:cls]. + ] +! + +treeViewClassHierarchyContents + "returns the contents of the root of the class tree list" + + |cls| + + resourceSuperclass notNil ifTrue:[ + cls := Smalltalk classNamed: resourceSuperclass. + ]. + cls := cls ? Object. + ^ cls +! + +treeViewClassHierarchyIcon + "returns the icon for aTreeItem as a block" + + ^[:aTreeItem| + |icon| + + aTreeItem contents isClass ifTrue:[ + icon := self class iconClass. + aTreeItem contents isPrivate ifTrue:[ + icon := self class iconPrivateClass + ]. + icon + ] ifFalse:[ + self class iconCategory + ] + ] +! + +treeViewClassHierarchyLabel + "returns the label for aTreeItem as a block" + + ^[:aTreeItem| + |label superCls itemContents| + + itemContents := aTreeItem contents. + label := itemContents name. +"/ (itemContents isPrivate +"/ and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)]) +"/ ifTrue: [label := label, ' (', superCls name, ')']. + label + ] +! ! + !ResourceSelectionBrowser::ResourceMethod methodsFor:'accessing'! iconOn:aGC @@ -1037,6 +1310,10 @@ "Modified: / 5.11.2001 / 16:48:35 / cg" ! +method + ^ method +! + method: aMethod "sets aMethod"