author | Claus Gittinger <cg@exept.de> |
Thu, 17 Oct 2019 15:47:47 +0200 | |
changeset 3790 | a28f8340a3eb |
parent 3652 | 2b6236bab321 |
permissions | -rw-r--r-- |
"{ Encoding: utf8 }" " COPYRIGHT (c) 1997-1998 by eXept Software AG All Rights Reserved This software is furnished under a license and may be used only in accordance with the terms of that license and with the inclusion of the above copyright notice. This software may not be provided or otherwise made available to, or used by, any other person. No title to or ownership of the software is hereby transferred. " "{ Package: 'stx:libtool2' }" "{ NameSpace: Smalltalk }" SelectionBrowser subclass:#ResourceSelectionBrowser instanceVariableNames:'resourceMethod resourceClass resourceSuperclass resourceTypes allClasses classSelectionBlock classFilter packageFilter metaClassOnly existingOnly filter classPresentation' classVariableNames:'LastClassPresentation' poolDictionaries:'' category:'Interface-Dialogs' ! Object subclass:#ResourceMethod instanceVariableNames:'method icon resourceType selector' classVariableNames:'' poolDictionaries:'' privateIn:ResourceSelectionBrowser ! !ResourceSelectionBrowser class methodsFor:'documentation'! copyright " COPYRIGHT (c) 1997-1998 by eXept Software AG All Rights Reserved This software is furnished under a license and may be used only in accordance with the terms of that license and with the inclusion of the above copyright notice. This software may not be provided or otherwise made available to, or used by, any other person. No title to or ownership of the software is hereby transferred. " ! documentation " The ResourceSelectionBrowser allows you to browse in class hierarchies and to select resource methods for loading or to saving resource specifications (#canvas, #menu, etc.). [instance variables:] resourceMethod <Symbol> selector of the resource spec resourceClass <Symbol> class of the resource spec resourceSuperclass <Symbol> root class of the tree list resourceTypes <Array> allowed resource types allClasses <Array> list of the subclasses of resourceSuperclass classSelectionBlock <Block> by evaluating this block the class selection is done classFilter <Block> if non-nil, given a class, has to return true for a class to be shown packageFilter <Block> if non-nil, given a package, has to return true for a class to be shown existingOnly <Boolean> 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 [author:] Thomas Zwick, eXept Software AG " ! ! !ResourceSelectionBrowser class methodsFor:'instance creation'! request:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes "opens a ResourceSelectionBrowser; return a Message-object (whoInfo) or nil." ^ (self title:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes ) openAndLetUserChoose " ResourceSelectionBrowser request: 'Select a Resource Selector' onSuperclass: #ApplicationModel andClass: MenuEditor andSelector: #menuItemImage withResourceTypes: #(image) " ! 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" ^ (self new title: aTitle) onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes " (ResourceSelectionBrowser title: 'Select a Resource Selector' onSuperclass: #ApplicationModel andClass: MenuEditor andSelector: #menuItemImage withResourceTypes: #(image) ) openAndLetUserChoose " ! ! !ResourceSelectionBrowser class methodsFor:'image specs'! iconCategory <resource: #image> "This resource specification was automatically generated by the ImageEditor of ST/X." "Do not manually edit this!! If it is corrupted, the ImageEditor may not be able to read the specification." " self iconCategory inspect ImageEditor openOnClass:self andSelector:#iconCategory" ^ Icon constantNamed:#'ResourceSelectionBrowser class iconCategory' ifAbsentPut:[ (Depth4Image new) width:18; height:16; photometric:(#palette); bitsPerSample:(#( 4 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'3L0@@@@@@L3L3L@@@@@@@@3L3@@3L3L3L0CL3@LQDQDQD#CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@LRH"H"H3CL3@L#L3L3L3CL3@@3L3L3L0CL3L@@@@@@@@3L3L0@@@@@@L3L'); colorMapFromArray:#[ 0 0 0 255 255 255 170 170 170 127 127 127 255 0 0 0 255 0 0 0 255 0 255 255 255 255 0 255 0 255 127 0 0 0 127 0 0 0 127 0 127 127 127 127 0 127 0 127 ]; mask:((ImageMask new) width:18; height:16; bits:(ByteArray fromPackedString:'<@O@8@G@3?3@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@3?3@8@G@<@O@'); yourself); yourself ] ! iconClass <resource: #image> "This resource specification was automatically generated by the ImageEditor of ST/X." "Do not manually edit this!! If it is corrupted, the ImageEditor may not be able to read the specification." " self iconClass inspect ImageEditor openOnClass:self andSelector:#iconClass" ^ Icon constantNamed:#'ResourceSelectionBrowser class iconClass' ifAbsentPut:[ (Depth2Image new) width:18; height:16; photometric:(#palette); bitsPerSample:(#( 2 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'@@@@@@@*****ABUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@A@@@@@@@@@@@@@b'); colorMapFromArray:#[ 0 0 0 170 170 170 255 255 255 ]; mask:((ImageMask new) width:18; height:16; bits:(ByteArray fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@'); yourself); yourself ] ! iconPrivateClass <resource: #image> "This resource specification was automatically generated by the ImageEditor of ST/X." "Do not manually edit this!! If it is corrupted, the ImageEditor may not be able to read the specification." " ImageEditor openOnClass:self andSelector:#iconPrivateClass" ^ Icon constantNamed:#'ResourceSelectionBrowser class iconPrivateClass' ifAbsentPut:[ (Depth2Image new) width:18; height:16; photometric:(#palette); bitsPerSample:(#( 2 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'@@@@@@PUUUUU A****(@F*??* @Z+??*@A*/*>(OF*>+: @Z+??*@A*/?:(DF*>** @Z+:**@A*/**(@F*>** @Z****C2@@@@@@@@@@@@@b'); colorMapFromArray:#[ 0 0 0 255 255 255 170 170 170 255 0 0 ]; mask:((ImageMask new) width:18; height:16; bits:(ByteArray fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@'); yourself); yourself ] ! ! !ResourceSelectionBrowser class methodsFor:'interface specs'! windowSpec "This resource specification was automatically generated by the UIPainter of ST/X." "Do not manually edit this!! If it is corrupted, the UIPainter may not be able to read the specification." " UIPainter new openOnClass:ResourceSelectionBrowser andSelector:#windowSpec ResourceSelectionBrowser new openInterface:#windowSpec ResourceSelectionBrowser open " <resource: #canvas> ^ #(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) ) ) ) ) (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' 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 -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'! tableColumnsForResourceMethodAttributes "This resource specification was automatically generated by the DataSetBuilder of ST/X." "Do not manually edit this!! If it is corrupted, the DataSetBuilder may not be able to read the specification." " DataSetBuilder new openOnClass:ResourceSelectionBrowser andSelector:#tableColumnsForResourceMethodAttributes " <resource: #tableColumns> ^ #( #(#DataSetColumnSpec #width: 20 #height: 20 #printSelector: #iconOn: #canSelect: false ) #(#DataSetColumnSpec #label: ' Selector' #labelAlignment: #left #model: #selector #canSelect: false ) #(#DataSetColumnSpec #label: ' Resource Type' #labelAlignment: #left #model: #resourceType #canSelect: false ) ) ! ! !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 "returns the value holder for the name of the class" |holder| (holder := builder bindingAt:#valueOfClassName) isNil ifTrue:[ builder aspectAt:#valueOfClassName put:(holder := '' asValue). holder onChangeEvaluate:[self classSelectionUpdate:holder value]. ]. ^ holder ! helpEnabled "returns whether there is a documentation file" ^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" ^ builder listAspectFor:#listOfResourceMethods ! resourceMethodColumns "returns the columns for the table of the resource methods as value holder" |holder| (holder := builder bindingAt:#resourceMethodColumns) isNil ifTrue:[ builder aspectAt:#resourceMethodColumns put:(holder := List new). holder addAll: (self class tableColumnsForResourceMethodAttributes collect: [:i| i decodeAsLiteralArray]). ]. ^ holder ! resourceSelectorHolder "returns the value holder for the name of the selector" ^ builder valueAspectFor:#resourceSelectorHolder initialValue:'' "Modified: / 09-03-2019 / 22:19:19 / Claus Gittinger" ! rootOfClassCategories "returns the value holder for the root of the class tree list" |holder| (holder := builder bindingAt:#rootOfClassCategories) isNil ifTrue:[ classPresentation = #'Class Categories' ifTrue: [ builder aspectAt:#rootOfClassCategories put: (holder := TreeItem name: 'Categories') ]. ]. ^ holder ! rootOfClassHierarchy "returns the value holder for the root of the class tree list" |holder| (holder := builder bindingAt:#rootOfClassHierarchy) isNil ifTrue:[ classPresentation = #'Class Hierarchy' ifTrue: [ builder aspectAt:#rootOfClassHierarchy put: (holder := TreeItem new) ] ]. ^ holder ! selectionOfClassCategories "returns the value holder for the selected class of the class tree list" |holder| (holder := builder bindingAt:#selectionOfClassCategories) isNil ifTrue:[ builder aspectAt:#selectionOfClassCategories put:(holder := ValueHolder new). ]. ^ holder ! selectionOfClassHierarchy "returns the value holder for the selected class of the class tree list" |holder| (holder := builder bindingAt:#selectionOfClassHierarchy) isNil ifTrue:[ builder aspectAt:#selectionOfClassHierarchy put:(holder := ValueHolder new). ]. ^ holder ! selectionOfClassPresentation "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 ? LastClassPresentation ? #'Class Categories')). holder onChangeEvaluate:[self classPresentationChanged ]. ]. ^ holder ! selectionOfResourceMethod "returns the value holder for the selected resource method of the resource method list" ^ builder valueAspectFor:#selectionOfResourceMethod initialValue:'' "Modified: / 09-03-2019 / 22:19:30 / Claus Gittinger" ! valueOfClassName <resource: #obsolete> "returns the value holder for the name of the class" self obsoleteMethodWarning:'stupid name - use #classNameHolder'. ^ self classNameHolder ! valueOfResourceSelector <resource: #obsolete> "returns the value holder for the name of the selector" self obsoleteMethodWarning:'stupid name - use #resourceSelectorHolder'. ^ self resourceSelectorHolder ! ! !ResourceSelectionBrowser methodsFor:'callbacks-user'! classPresentationChanged "returns the value holder for the selected class presentation (Flat, Hierarchy or Category)" |comp newRoot| classPresentation := LastClassPresentation := self selectionOfClassPresentation value. 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. ]. 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 "/ ]. "/ ]. "/ ]. 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. ]. ]. ]. ]. 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:#()) ]. ] ! 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. ] ] ! 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 ]. item notNil ifTrue:[ item contents ~~ #Category ifTrue:[ className := item name. class := Smalltalk at:className asSymbol. ] ]. ] ifFalse:[ class := resourceClass ]. class isNil ifTrue: [ self listOfResourceMethods contents:#(). ^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 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 "returns whether a class may be selected" |cont| ^ (cont := aTreeItem contents) ~= '' and: [cont ~~ self treeViewClassHierarchyContents] ! ! !ResourceSelectionBrowser methodsFor:'initialization'! initialize "Invoked when a new instance is created." metaClassOnly := true. existingOnly := false. super initialize. ! ! !ResourceSelectionBrowser methodsFor:'instance creation'! onSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes "create - but do not yet open a ResourceSelectionBrowser" |cls| resourceMethod := aSelector. resourceTypes := aResourceTypes. resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol]. resourceClass := nil. aClassOrClassName notNil ifTrue:[ aClassOrClassName isClass ifTrue: [ cls := aClassOrClassName. resourceClass := aClassOrClassName ] ifFalse: [ cls := Smalltalk classNamed: aClassOrClassName. cls notNil ifTrue:[ resourceClass := cls ] ] ]. 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:[ (selectedClass := self selectionOfClassCategories value) isNil ifTrue:[ (enteredClassName := self classNameHolder value) isNil ifTrue:[ accept value ifTrue:[ self warn:'No valid class selected/entered'. ]. ^ nil ] ] ]. className := enteredClassName. className isNil ifTrue:[ className := selectedClass name ]. cls := Smalltalk classNamed:className. (cls isClass and:[accept value]) ifTrue:[ ^ Method::MethodWhoInfo class:cls selector:(self resourceSelectorHolder value) ]. accept value ifTrue:[ self warn:'No valid class selected/entered'. ]. ^ 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" 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]. (classSelection isNil or:[ (Smalltalk classNamed: classSelection) isNil]) ifTrue: [classSelection := self class lastSelection]. "/ (classSelection isNil or:[Smalltalk at: classSelection]) isNil "/ ifTrue: [classSelection := self treeViewContents]. classSelectionBlock := [:clsPattern | self classSelectionUpdate:clsPattern]. self classNameHolder value:classSelection. (classNameInputField := builder componentAt: #classNameInputField) entryCompletionBlock: [:value| |s what m| s := classNameInputField contents withoutSpaces. what := Smalltalk classnameCompletion:s inEnvironment:Smalltalk. 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. "/ classNameInputField contents:what first. "/ oldClassName = classNameInputField contents ifTrue:[classNameInputField flash]. "/ classSelectionBlock value: classNameInputField contents ]. classSelectionBlock value: self classNameHolder value. "/ self updateResourceMethodList. -- will be done automatically via change 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" 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 "registers and returns an icon indicating the resource type" |cls sel image imageKey| self resourceType isNil ifTrue: [^nil]. icon isNil ifTrue:[ ((self resourceType = #image) or: [resourceType = #fileImage]) ifTrue:[ cls := method mclass theNonMetaclass. sel := method selector. ] ifFalse: [ cls := SystemBrowser. sel := (resourceType, 'Icon') asSymbol. ]. imageKey := (cls name, sel) asSymbol. (icon := aGC registeredImageAt: imageKey) isNil ifTrue: [ image := cls perform: sel. (image extent y > 18) ifTrue: [ image := image magnifiedBy: 18/image extent y ]. aGC registerImage: image key: imageKey. icon := aGC registeredImageAt: imageKey. ]. ]. ^icon "Modified: / 5.11.2001 / 16:48:35 / cg" ! method ^ method ! method: aMethod "sets aMethod" method := aMethod ! resourceType "returns resourceType" resourceType isNil ifTrue: [resourceType := method resourceType]. ^resourceType ! selector "returns selector" selector isNil ifTrue: [selector := method who methodSelector]. ^selector ! ! !ResourceSelectionBrowser class methodsFor:'documentation'! version ^ '$Header$' ! version_CVS ^ '$Header$' ! !