hg/stx-libtool2: comparison ResourceSelectionBrowser.st

equal deleted inserted replaced

-:d76ed66a63ed
+:f6fb9ac10ac5
 subclassesAndPrivateClassesPerClass := IdentityDictionary new.
 Smalltalk allClassesDo:[:cls |
 |owner superclass info|
-(owner := cls owningClass) notNil ifTrue:[
+"/        (owner := cls owningClass) notNil ifTrue:[
-info := subclassesAndPrivateClassesPerClass at:owner ifAbsent:nil.
+"/            info := subclassesAndPrivateClassesPerClass at:owner ifAbsent:nil.
-info isNil ifTrue:[
+"/            info isNil ifTrue:[
-subclassesAndPrivateClassesPerClass at:owner put:(info := Array with:IdentitySet new
+"/                subclassesAndPrivateClassesPerClass at:owner put:(info := Array with:IdentitySet new
-with:IdentitySet new).
+"/                                                                                with:IdentitySet new).
-].
+"/            ].
-(info at:2) add:cls
+"/            (info at:2) add:cls
-] ifFalse:[
+"/        ] 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|
 ^[:aTreeItem|
 |label superCls itemContents|
 itemContents := aTreeItem contents.
 label := itemContents name.
-(itemContents isPrivate
+"/        (itemContents isPrivate
-and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)])
+"/        and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)])
-ifTrue: [label := label, ' (', superCls name, ')'].
+"/            ifTrue: [label := label, ' (', superCls name, ')'].
 label
 ]
 ! !
 !ResourceSelectionBrowser class methodsFor:'image specs'!
 iconCategory
 |cont children initialContents setOfCategories itemCategory setOfClasses|
 (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 , ' (', 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]
 ]
 ].
 ].
 children
 ]
 !
 treeViewClassCategoryIcon
 "returns the icon for aTreeItem as a block"
 !ResourceSelectionBrowser methodsFor:'callbacks-user'!
 classSelected
 "after a class selection, read the allowed resource methods of the selected class"
-ClassPresentation = #'Class Hierarchy'
+|sel|
-ifTrue:  [self selectionOfClassHierarchy  value isNil ifTrue: [^nil]]
-ifFalse: [self selectionOfClassCategories value isNil ifTrue: [^nil]].
+"/    ClassPresentation = #'Class Hierarchy'
+"/        ifTrue:  [sel := self selectionOfClassHierarchy value]
+"/        ifFalse: [sel := self selectionOfClassCategories value].
+"/
+"/    sel notNil ifTrue:[
+"/        resourceClass := sel name.
+"/    ].
+self updateResourceMethodList.
+!
+classSelectionUpdate:clsPattern
+|foundClass classes|
+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: [nil]
+].
+foundClass notNil ifTrue: [
+foundClass isLoaded ifFalse:[
+foundClass autoload.
+foundClass := Smalltalk at:foundClass name.
+].
+ClassPresentation = #'Class Hierarchy' ifTrue: [
+|searchArgs nonSuperclasses hierItem|
+false "foundClass isPrivate"
+ifFalse: [searchArgs := foundClass withAllSuperclasses reverse]
+ifTrue:  [searchArgs := foundClass owningClass withAllSuperclasses reverse. 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.
+].
+].
+].
+self valueOfClassName value: clsPattern
+!
+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 valueOfResourceSelector value: self selectionOfResourceMethod value selector]
+!
+updateResourceMethodList
+"read the allowed resource methods of the selected class"
+|class className item|
+resourceClass notNil ifTrue:[
+class := Smalltalk at:resourceClass asSymbol.
+].
+class 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 theNonMetaclass name.
 self withWaitCursorDo:
 [
-|clsName newContents class|
+|newContents|
 resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes].
-ClassPresentation = #'Class Hierarchy'
+self valueOfClassName value: className.
-ifTrue:  [clsName := (self selectionOfClassHierarchy  value name upTo: $ ) asSymbol]
+self class lastSelection: className.
-ifFalse: [clsName := (self selectionOfClassCategories value name upTo: $ ) asSymbol].
-self valueOfClassName value: clsName.
-self class lastSelection: clsName.
-class := Smalltalk at: clsName.
 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
 .
 ]
-!
-classSelectionUpdate:clsPattern
-|foundClass classes|
-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: [nil]
-].
-foundClass notNil
-ifTrue:
-[
-ClassPresentation = #'Class Hierarchy'
-ifTrue:
-[
-|searchArgs nonSuperclasses|
-foundClass isPrivate
-ifFalse: [searchArgs := foundClass withAllSuperclasses reverse]
-ifTrue:  [searchArgs := foundClass owningClass withAllSuperclasses reverse. searchArgs add: foundClass]
-.
-(nonSuperclasses := self treeViewClassHierarchyContents allSuperclasses) notNil
-ifTrue: [searchArgs := searchArgs reject: [:cls| nonSuperclasses includes: cls]].
-self selectionOfClassHierarchy value: (self rootOfClassHierarchy detectChild:[:child :arg| child contents == arg] arguments:searchArgs).
-]
-ifFalse:
-[
-|searchArgs|
-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].
-self selectionOfClassCategories value: (self rootOfClassCategories detectChild:[:child :arg| (child name upTo: $ ) = arg] arguments:searchArgs).
-].
-].
-self valueOfClassName value: clsPattern
-!
-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 valueOfResourceSelector value: self selectionOfResourceMethod value selector]
 ! !
 !ResourceSelectionBrowser methodsFor:'instance creation'!
 openOnSuperclass: aSuperclassOrSymbol andClass: aClassOrSymbol andSelector: aSelector withResourceTypes: aResourceTypes
 aSuperclassOrSymbol,
 and aClassOrSymbol,
 and aSelector,
 with allowed aResourceTypes"
-|clsName clsNameString|
+|clsName clsNameString cls|
 resourceMethod := aSelector.
 resourceTypes := aResourceTypes.
 resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol].
 resourceClass := nil.
 aClassOrSymbol isClass
-ifTrue: [resourceClass := aClassOrSymbol name]
+ifTrue: [cls := aClassOrSymbol. resourceClass := aClassOrSymbol name]
 ifFalse: [
 aClassOrSymbol size > 0 ifTrue:[
-(Smalltalk at: aClassOrSymbol) notNil
+(cls := Smalltalk at: aClassOrSymbol) notNil
 ifTrue: [resourceClass := aClassOrSymbol]
 ]
 ].
 self valueOfResourceSelector value:(aSelector ? '').
+cls notNil ifTrue:[
+"/ TODO: update tree
+].
 self open.
 (clsName := self selectionOfClassHierarchy value) isNil ifTrue:[
 (clsName := self selectionOfClassCategories value) isNil ifTrue:[
 (clsNameString := self valueOfClassName value) isNil ifTrue:[
 allClasses := self treeViewClassHierarchyContents withAllSubclasses reject: [:cls| cls isPrivate].
 classSelection :=  resourceClass.
 (classSelection isNil or:[Smalltalk at: classSelection]) isNil
 ifTrue: [classSelection :=  self class lastSelection].
-(classSelection isNil or:[Smalltalk at: classSelection]) isNil
+"/    (classSelection isNil or:[Smalltalk at: classSelection]) isNil
-ifTrue: [classSelection :=  self treeViewContents].
+"/        ifTrue: [classSelection :=  self treeViewContents].
 classSelectionBlock := [:clsPattern | self classSelectionUpdate:clsPattern].
 self valueOfClassName value: classSelection.
 (classNameInputField := builder componentAt: #classNameInputField) entryCompletionBlock:
 oldClassName = classNameInputField contents ifTrue:[classNameInputField flash].
 classSelectionBlock value: classNameInputField contents
 ].
 classSelectionBlock value: self valueOfClassName value.
-self classSelected.
+self updateResourceMethodList.
 self selectionOfResourceMethod value: (self listOfResourceMethods detect: [:m| m selector == resourceMethod] ifNone: nil).
 ^super postBuildWith:aBuilder
 !
 postOpenWith:aBuilder
 "after opening and if turned on make hierarchy view visible"

changeset 1732	f6fb9ac10ac5
parent 1725	2de97eb77984
child 1751	fd6ac12ed9e4