tz@425: "
tz@771:  COPYRIGHT (c) 1997-1998 by eXept Software AG
tz@425:               All Rights Reserved
tz@425: 
tz@425:  This software is furnished under a license and may be used
tz@425:  only in accordance with the terms of that license and with the
tz@425:  inclusion of the above copyright notice. This software may not
tz@425:  be provided or otherwise made available to, or used by, any
tz@425:  other person. No title to or ownership of the software is
tz@425:  hereby transferred.
tz@425: "
cg@1384: "{ Package: 'stx:libtool2' }"
cg@1384: 
cg@3198: "{ NameSpace: Smalltalk }"
cg@3198: 
tz@425: SelectionBrowser subclass:#ResourceSelectionBrowser
tz@477: 	instanceVariableNames:'resourceMethod resourceClass resourceSuperclass resourceTypes
tz@906: 		allClasses classSelectionBlock'
tz@906: 	classVariableNames:'ClassPresentation'
tz@425: 	poolDictionaries:''
tz@619: 	category:'Interface-Dialogs'
tz@425: !
tz@425: 
tz@771: Object subclass:#ResourceMethod
tz@523: 	instanceVariableNames:'method icon resourceType selector'
tz@523: 	classVariableNames:''
tz@523: 	poolDictionaries:''
tz@523: 	privateIn:ResourceSelectionBrowser
tz@523: !
tz@523: 
tz@425: !ResourceSelectionBrowser class methodsFor:'documentation'!
tz@425: 
tz@425: copyright
tz@425: "
tz@771:  COPYRIGHT (c) 1997-1998 by eXept Software AG
tz@425:               All Rights Reserved
tz@425: 
tz@425:  This software is furnished under a license and may be used
tz@425:  only in accordance with the terms of that license and with the
tz@425:  inclusion of the above copyright notice. This software may not
tz@425:  be provided or otherwise made available to, or used by, any
tz@425:  other person. No title to or ownership of the software is
tz@425:  hereby transferred.
tz@425: "
tz@425: 
tz@425: !
tz@425: 
tz@425: documentation
tz@425: "
tz@746:     The ResourceSelectionBrowser allows you to browse in class hierarchies
tz@771:     and to select resource methods for loading or to saving resource 
tz@771:     specifications (#canvas, #menu, etc.).
tz@771: 
tz@771:     [instance variables:]
tz@907:         resourceMethod          <Symbol>        selector of the resource spec
tz@907:         resourceClass           <Symbol>        class of the resource spec
tz@907:         resourceSuperclass      <Symbol>        root class of the tree list
tz@907:         resourceTypes           <Array>         allowed resource types
tz@907:         allClasses              <Array>         list of the subclasses of resourceSuperclass
tz@907:         classSelectionBlock     <Block>         by evaluating this block the class selection is done
tz@746: 
tz@504:     [start with:]
tz@907:         ResourceSelectionBrowser open
tz@504: 
tz@504:     [author:]
tz@907:         Thomas Zwick, eXept Software AG
tz@425: "
tz@425: ! !
tz@425: 
tz@425: !ResourceSelectionBrowser class methodsFor:'instance creation'!
tz@425: 
cg@1978: request:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes
cg@1978:     "opens a ResourceSelectionBrowser; return a Message-object or nil."
cg@1978: 
cg@1978:     ^ (self new
cg@1978:         title: aTitle)
cg@1978:             openOnSuperclass:aSuperclass
cg@1978:             andClass:aClassOrClassName
cg@1978:             andSelector:aSelector
cg@1978:             withResourceTypes:resourceTypes
cg@1978: 
tz@649:     "
cg@1978:      ResourceSelectionBrowser
tz@906:         request: 'Select a Resource Selector'
tz@906:         onSuperclass: #ApplicationModel 
cg@1978:         andClassNamed: #MenuEditor 
tz@906:         andSelector: #menuItemImage 
tz@906:         withResourceTypes: #(image) 
tz@425:     "
tz@425: ! !
tz@425: 
cg@1725: !ResourceSelectionBrowser class methodsFor:'callbacks-default'!
tz@648: 
tz@906: treeViewClassHierarchyChildren
tz@771:     "returns the children for the contents (class) of aTreeItem as a block"
tz@648: 
cg@1034:     "/ cg: tz's algorithm was very-very slow, 
cg@1034:     "/ (it enumerated classes hundreds of times,
cg@1034:     "/  leading to a square runtime behavior
cg@1034:     "/  - i.e. very slow scrolling )
cg@1034:     "/ Speed up things by caching facts while enumerating
cg@1034:     "/ classes once only.
cg@1034: 
cg@1034:     |subclassesAndPrivateClassesPerClass|
cg@1034: 
cg@1034:     subclassesAndPrivateClassesPerClass := IdentityDictionary new.
cg@1034: 
cg@1034:     Smalltalk allClassesDo:[:cls |
cg@1034:         |owner superclass info|
cg@1034: 
cg@1732: "/        (owner := cls owningClass) notNil ifTrue:[
cg@1732: "/            info := subclassesAndPrivateClassesPerClass at:owner ifAbsent:nil.
cg@1732: "/            info isNil ifTrue:[
cg@1732: "/                subclassesAndPrivateClassesPerClass at:owner put:(info := Array with:IdentitySet new 
cg@1732: "/                                                                                with:IdentitySet new).
cg@1732: "/            ].
cg@1732: "/            (info at:2) add:cls
cg@1732: "/        ] ifFalse:[
cg@1034:             superclass := cls superclass.
cg@1034:             superclass notNil ifTrue:[
cg@1034:                 info := subclassesAndPrivateClassesPerClass at:superclass ifAbsent:nil.
cg@1034:                 info isNil ifTrue:[
cg@1034:                     subclassesAndPrivateClassesPerClass at:superclass put:(info := Array with:IdentitySet new 
cg@1034:                                                                                          with:IdentitySet new).
cg@1034:                 ].
cg@1034:                 (info at:1) add:cls
cg@1034:             ]
cg@1732: "/        ]
cg@1034:     ].
cg@1034: 
cg@1034:     ^ [:aTreeItem|
cg@1034:         |classes itemClass info|
cg@1034: 
tz@906:         classes := OrderedCollection new. 
cg@1034:         itemClass := aTreeItem contents.
cg@1034:         info := subclassesAndPrivateClassesPerClass at:itemClass ifAbsent:nil.
cg@1034:         info notNil ifTrue:[
cg@1034:             classes addAll:((info at:1) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]).
cg@1034:             classes addAll:((info at:2) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]).
cg@1034:         ].
tz@906:         classes
tz@718:      ]
tz@648: !
tz@648: 
tz@906: treeViewClassHierarchyContents
tz@771:     "returns the default contents of the root of the class tree list"
tz@648: 
cg@802:     ^ Object
tz@648: 
tz@648: !
tz@648: 
tz@906: treeViewClassHierarchyIcon
tz@771:     "returns the icon for aTreeItem as a block"
tz@648: 
tz@718:     ^[:aTreeItem|
tz@906:         |icon|
cg@1034: 
cg@1034:         aTreeItem contents isClass ifTrue:[
tz@906:             icon := self iconClass.
cg@1034:             aTreeItem contents isPrivate ifTrue:[
tz@906:                icon := self iconPrivateClass
tz@906:             ].
tz@906:             icon
cg@1034:         ] ifFalse:[
tz@906:             self iconCategory
tz@906:         ]
tz@771:     ]
tz@648: 
tz@648: !
tz@648: 
tz@906: treeViewClassHierarchyLabel
tz@771:     "returns the label for aTreeItem as a block"
tz@648: 
tz@718:     ^[:aTreeItem|
cg@1034:         |label superCls itemContents|
cg@1034: 
cg@1034:         itemContents := aTreeItem contents.
cg@1034:         label := itemContents name.
cg@1732: "/        (itemContents isPrivate 
cg@1732: "/        and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)])
cg@1732: "/            ifTrue: [label := label, ' (', superCls name, ')'].
tz@906:         label
tz@718:      ]
tz@648: ! !
tz@648: 
tz@730: !ResourceSelectionBrowser class methodsFor:'image specs'!
tz@730: 
tz@906: iconCategory
sv@3117:     <resource: #image>
tz@906:     "This resource specification was automatically generated
tz@906:      by the ImageEditor of ST/X."
tz@906:     "Do not manually edit this!! If it is corrupted,
tz@906:      the ImageEditor may not be able to read the specification."
tz@906:     "
tz@906:      self iconCategory inspect
sv@3117:      ImageEditor openOnClass:self andSelector:#iconCategory"
sv@3117:     
sv@3117:     ^ Icon constantNamed:#'ResourceSelectionBrowser class iconCategory'
sv@3117:         ifAbsentPut:[
sv@3117:             (Depth4Image new)
sv@3117:                 width:18;
sv@3117:                 height:16;
sv@3117:                 photometric:(#palette);
sv@3117:                 bitsPerSample:(#( 4 ));
sv@3117:                 samplesPerPixel:(1);
sv@3117:                 bits:(ByteArray 
sv@3117:                             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');
sv@3117:                 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 ];
sv@3117:                 mask:((ImageMask new)
sv@3117:                             width:18;
sv@3117:                             height:16;
sv@3117:                             bits:(ByteArray 
sv@3117:                                         fromPackedString:'<@O@8@G@3?3@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@7?;@3?3@8@G@<@O@');
sv@3117:                             yourself);
sv@3117:                 yourself
sv@3117:         ]
cg@1493: !
tz@906: 
tz@730: iconClass
sv@3117:     <resource: #image>
tz@746:     "This resource specification was automatically generated
tz@746:      by the ImageEditor of ST/X."
tz@746:     "Do not manually edit this!! If it is corrupted,
tz@746:      the ImageEditor may not be able to read the specification."
tz@730:     "
cg@1404:      self iconClass inspect
sv@3117:      ImageEditor openOnClass:self andSelector:#iconClass"
sv@3117:     
sv@3117:     ^ Icon constantNamed:#'ResourceSelectionBrowser class iconClass'
sv@3117:         ifAbsentPut:[
sv@3117:             (Depth2Image new)
sv@3117:                 width:18;
sv@3117:                 height:16;
sv@3117:                 photometric:(#palette);
sv@3117:                 bitsPerSample:(#( 2 ));
sv@3117:                 samplesPerPixel:(1);
sv@3117:                 bits:(ByteArray 
sv@3117:                             fromPackedString:'@@@@@@@*****ABUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@BUUUUT@IUUUUP@%UUUU@A@@@@@@@@@@@@@b');
sv@3117:                 colorMapFromArray:#[ 0 0 0 170 170 170 255 255 255 ];
sv@3117:                 mask:((ImageMask new)
sv@3117:                             width:18;
sv@3117:                             height:16;
sv@3117:                             bits:(ByteArray 
sv@3117:                                         fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@');
sv@3117:                             yourself);
sv@3117:                 yourself
sv@3117:         ]
cg@1493: !
tz@730: 
tz@730: iconPrivateClass
sv@3117:     <resource: #image>
tz@746:     "This resource specification was automatically generated
tz@746:      by the ImageEditor of ST/X."
tz@746:     "Do not manually edit this!! If it is corrupted,
tz@746:      the ImageEditor may not be able to read the specification."
tz@730:     "
sv@3117:      ImageEditor openOnClass:self andSelector:#iconPrivateClass"
sv@3117:     
sv@3117:     ^ Icon constantNamed:#'ResourceSelectionBrowser class iconPrivateClass'
sv@3117:         ifAbsentPut:[
sv@3117:             (Depth2Image new)
sv@3117:                 width:18;
sv@3117:                 height:16;
sv@3117:                 photometric:(#palette);
sv@3117:                 bitsPerSample:(#( 2 ));
sv@3117:                 samplesPerPixel:(1);
sv@3117:                 bits:(ByteArray 
sv@3117:                             fromPackedString:'@@@@@@PUUUUU A****(@F*??* @Z+??*@A*/*>(OF*>+: @Z+??*@A*/?:(DF*>** @Z+:**@A*/**(@F*>** @Z****C2@@@@@@@@@@@@@b');
sv@3117:                 colorMapFromArray:#[ 0 0 0 255 255 255 170 170 170 255 0 0 ];
sv@3117:                 mask:((ImageMask new)
sv@3117:                             width:18;
sv@3117:                             height:16;
sv@3117:                             bits:(ByteArray 
sv@3117:                                         fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@');
sv@3117:                             yourself);
sv@3117:                 yourself
sv@3117:         ]
cg@1493: ! !
tz@730: 
tz@425: !ResourceSelectionBrowser class methodsFor:'interface specs'!
tz@425: 
tz@425: windowSpec
tz@746:     "This resource specification was automatically generated
tz@746:      by the UIPainter of ST/X."
tz@425: 
tz@746:     "Do not manually edit this!! If it is corrupted,
tz@746:      the UIPainter may not be able to read the specification."
tz@425: 
tz@425:     "
tz@425:      UIPainter new openOnClass:ResourceSelectionBrowser andSelector:#windowSpec
tz@425:      ResourceSelectionBrowser new openInterface:#windowSpec
tz@746:      ResourceSelectionBrowser open
tz@425:     "
tz@425: 
tz@425:     <resource: #canvas>
tz@425: 
cg@1384:     ^ 
cg@1751:      #(FullSpec
cg@1751:         name: windowSpec
cg@1751:         window: 
cg@1751:        (WindowSpec
cg@1751:           label: 'Resource Selection Browser'
cg@1751:           name: 'Resource Selection Browser'
cg@1751:           min: (Point 400 300)
cg@1751:           bounds: (Rectangle 12 22 612 372)
cg@1384:         )
cg@1751:         component: 
cg@1751:        (SpecCollection
cg@1751:           collection: (
cg@1751:            (VariableHorizontalPanelSpec
cg@1751:               name: 'VariableHorizontalPanel'
cg@1751:               layout: (LayoutFrame 0 0.0 0 0.0 0 1.0 -36 1.0)
cg@1751:               component: 
cg@1751:              (SpecCollection
cg@1751:                 collection: (
cg@1751:                  (ViewSpec
cg@1751:                     name: 'Box1'
cg@1751:                     component: 
cg@1751:                    (SpecCollection
cg@1751:                       collection: (
cg@1751:                        (HorizontalPanelViewSpec
cg@1751:                           name: 'HorizontalPanel2'
cg@1751:                           layout: (LayoutFrame 0 0 2 0 297 0 23 0)
cg@1751:                           horizontalLayout: leftSpace
cg@1751:                           verticalLayout: fit
cg@1751:                           horizontalSpace: 3
cg@1751:                           verticalSpace: 3
cg@1751:                           component: 
cg@1751:                          (SpecCollection
cg@1751:                             collection: (
cg@1751:                              (RadioButtonSpec
cg@1751:                                 label: 'Categories'
cg@1751:                                 name: 'ClassCategoriesRadioButton'
cg@1751:                                 translateLabel: true
cg@1751:                                 model: selectionOfClassPresentation
cg@1751:                                 isTriggerOnDown: true
cg@1751:                                 lampColor: (Color 0.0 0.0 0.0)
cg@1751:                                 select: #'Class Categories'
cg@1751:                                 extent: (Point 124 21)
tz@773:                               )
cg@1751:                              (RadioButtonSpec
cg@1751:                                 label: 'Hierarchy'
cg@1751:                                 name: 'ClassHierarchyRadioButton'
cg@1751:                                 translateLabel: true
cg@1751:                                 model: selectionOfClassPresentation
cg@1751:                                 isTriggerOnDown: true
cg@1751:                                 lampColor: (Color 0.0 0.0 0.0)
cg@1751:                                 select: #'Class Hierarchy'
cg@1751:                                 extent: (Point 145 21)
tz@773:                               )
cg@1384:                              )
cg@1384:                            
tz@773:                           )
tz@773:                         )
cg@1751:                        (SelectionInTreeViewSpec
cg@1751:                           name: 'listOfClassHierarchyView'
cg@1751:                           layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0)
cg@1751:                           tabable: true
cg@1751:                           model: selectionOfClassHierarchy
cg@1751:                           hasHorizontalScrollBar: true
cg@1751:                           hasVerticalScrollBar: true
cg@1751:                           miniScrollerHorizontal: true
cg@1751:                           showDirectoryIndicatorForRoot: false
cg@1751:                           showDirectoryIndicator: true
cg@1751:                           valueChangeSelector: classSelected
cg@1751:                           hierarchicalList: rootOfClassHierarchy
cg@1751:                           validateDoubleClickSelector: validateDoubleClick:
cg@1751:                           contentsSelector: treeViewClassHierarchyContents
cg@1751:                           labelSelector: treeViewClassHierarchyLabel
cg@1751:                           childrenSelector: treeViewClassHierarchyChildren
cg@1751:                           iconSelector: treeViewClassHierarchyIcon
cg@1751:                           highlightMode: line
cg@1384:                         )
cg@1751:                        (SelectionInTreeViewSpec
cg@1751:                           name: 'listOfClassCategoriesView'
cg@1751:                           layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0)
cg@1751:                           tabable: true
cg@1751:                           model: selectionOfClassCategories
cg@1751:                           hasHorizontalScrollBar: true
cg@1751:                           hasVerticalScrollBar: true
cg@1751:                           miniScrollerHorizontal: true
cg@1751:                           showRoot: false
cg@1751:                           showDirectoryIndicator: true
cg@1751:                           valueChangeSelector: classSelected
cg@1751:                           hierarchicalList: rootOfClassCategories
cg@1751:                           validateDoubleClickSelector: validateDoubleClick:
cg@1751:                           childrenSelector: treeViewClassCategoryChildren
cg@1751:                           iconSelector: treeViewClassCategoryIcon
cg@1751:                           highlightMode: line
cg@1384:                         )
cg@1751:                        (InputFieldSpec
cg@1751:                           name: 'classNameInputField'
cg@1751:                           layout: (LayoutFrame 2 0.0 -22 1 -1 1.0 0 1)
cg@1751:                           tabable: true
cg@1986:                           model: classNameHolder
cg@1751:                           acceptOnLeave: true
cg@1751:                           acceptOnLostFocus: true
cg@1751:                           acceptOnPointerLeave: true
cg@1384:                         )
cg@1384:                        )
cg@1384:                      
tz@773:                     )
cg@1384:                   )
cg@1751:                  (ViewSpec
cg@1751:                     name: 'Box2'
cg@1751:                     component: 
cg@1751:                    (SpecCollection
cg@1751:                       collection: (
cg@1751:                        (DataSetSpec
cg@1751:                           name: 'resourcesDataSetView'
cg@1751:                           layout: (LayoutFrame 2 0.0 2 0.0 -2 1.0 -24 1.0)
cg@1751:                           model: selectionOfResourceMethod
cg@1751:                           hasHorizontalScrollBar: true
cg@1751:                           hasVerticalScrollBar: true
cg@1751:                           miniScrollerHorizontal: true
cg@1751:                           rowClassName: 'ResourceSelectionBrowser::Row'
cg@1751:                           dataList: listOfResourceMethods
cg@1751:                           useIndex: false
cg@1751:                           has3Dsepartors: true
cg@1751:                           has3Dseparators: true
cg@1751:                           doubleClickSelector: resourceDoubleClicked
cg@1751:                           columnHolder: resourceMethodColumns
cg@1751:                           valueChangeSelector: resourceSelected
cg@1751:                           verticalSpacing: 1
cg@1384:                         )
cg@1751:                        (InputFieldSpec
cg@1751:                           name: 'selectorInputField'
cg@1751:                           layout: (LayoutFrame 2 0.0 -22 1 -2 1.0 0 1)
cg@1751:                           tabable: true
cg@1986:                           model: resourceSelectorHolder
cg@1751:                           acceptOnLeave: true
cg@1751:                           acceptOnLostFocus: true
cg@1751:                           acceptOnPointerLeave: true
tz@906:                         )
cg@1384:                        )
cg@1384:                      
tz@906:                     )
cg@1384:                   )
cg@1384:                  )
cg@1384:                
tz@773:               )
cg@1751:               handles: (Any 0.5 1.0)
cg@1384:             )
cg@1751:            (HorizontalPanelViewSpec
cg@1751:               name: 'ButtonPanel'
cg@1751:               layout: (LayoutFrame 2 0.0 -30 1 -2 1.0 -4 1.0)
cg@1751:               horizontalLayout: fit
cg@1751:               verticalLayout: fit
cg@1751:               reverseOrderIfOKAtLeft: true
cg@1751:               component: 
cg@1751:              (SpecCollection
cg@1751:                 collection: (
cg@1751:                  (ActionButtonSpec
cg@1751:                     label: 'Help'
cg@1751:                     name: 'HelpButton'
cg@1751:                     activeHelpKey: dss
cg@1751:                     model: openHTMLDocument:
cg@1751:                     initiallyDisabled: true
cg@1751:                     enableChannel: helpEnabled
cg@1751:                     actionValue: 'tools/uipainter/ResourceSelectionBrowser.html'
cg@1751:                     extent: (Point 196 26)
cg@1384:                   )
cg@1751:                  (ActionButtonSpec
cg@1751:                     label: 'Cancel'
cg@1751:                     name: 'cancelButton'
cg@1751:                     activeHelpKey: commitCancel
cg@1751:                     tabable: true
cg@1751:                     model: cancel
cg@1751:                     extent: (Point 197 26)
cg@1384:                   )
cg@1751:                  (ActionButtonSpec
cg@1751:                     label: 'OK'
cg@1751:                     name: 'okButton'
cg@1751:                     activeHelpKey: commitOK
cg@1751:                     tabable: true
cg@1751:                     model: accept
cg@1751:                     isDefault: true
cg@1751:                     extent: (Point 197 26)
cg@1384:                   )
cg@1384:                  )
cg@1384:                
cg@1384:               )
cg@1384:             )
cg@1384:            )
cg@1384:          
cg@1384:         )
tz@425:       )
tz@425: ! !
tz@425: 
tz@648: !ResourceSelectionBrowser class methodsFor:'list specs'!
tz@648: 
tz@822: tableColumnsForResourceMethodAttributes
tz@821:     "This resource specification was automatically generated
tz@821:      by the DataSetBuilder of ST/X."
tz@821: 
tz@821:     "Do not manually edit this!! If it is corrupted,
tz@821:      the DataSetBuilder may not be able to read the specification."
tz@821: 
tz@821:     "
tz@822:      DataSetBuilder new openOnClass:ResourceSelectionBrowser andSelector:#tableColumnsForResourceMethodAttributes
tz@821:     "
tz@821: 
tz@821:     <resource: #tableColumns>
tz@821: 
tz@648: 
tz@821:     ^ #(
tz@821:         #(#DataSetColumnSpec
tz@821:            #width: 20
tz@821:            #height: 20
tz@821:            #printSelector: #iconOn:
tz@821:            #canSelect: false
tz@821:        )
tz@821:         #(#DataSetColumnSpec
tz@821:            #label: ' Selector'
tz@821:            #labelAlignment: #left
tz@821:            #model: #selector
tz@821:            #canSelect: false
tz@821:        )
tz@821:         #(#DataSetColumnSpec
tz@821:            #label: ' Resource Type'
tz@821:            #labelAlignment: #left
tz@821:            #model: #resourceType
tz@821:            #canSelect: false
tz@821:        )
tz@821:      )
tz@648: ! !
tz@648: 
tz@425: !ResourceSelectionBrowser methodsFor:'aspects'!
tz@425: 
cg@1986: classNameHolder
cg@1986:     "returns the value holder for the name of the class"
cg@1986: 
cg@1986:     |holder|
cg@1986: 
cg@1986:     (holder := builder bindingAt:#valueOfClassName) isNil ifTrue:[
cg@1986:         builder aspectAt:#valueOfClassName put:(holder :=  '' asValue).
cg@1986:         holder onChangeEvaluate:[self classSelectionUpdate:holder value].
cg@1986:     ].
cg@1986:     ^ holder
cg@1986: !
cg@1986: 
tz@773: helpEnabled
tz@773:     "returns whether there is a documentation file"
tz@773: 
tz@773:     ^true
tz@773: !
tz@773: 
tz@771: listOfResourceMethods
tz@771:     "returns the value holder for the list of the resource methods"
tz@648: 
cg@1184:     ^ builder listAspectFor:#listOfResourceMethods
tz@648: !
tz@648: 
tz@771: resourceMethodColumns
tz@771:     "returns the columns for the table of the resource methods as value holder"
tz@425: 
tz@425:     |holder|
tz@771:     (holder := builder bindingAt:#resourceMethodColumns) isNil ifTrue:[
tz@821:         builder aspectAt:#resourceMethodColumns put:(holder := List new).
tz@822:         holder addAll: (self class tableColumnsForResourceMethodAttributes collect: [:i| i decodeAsLiteralArray]).
tz@771:     ].
tz@771:     ^ holder
tz@771: !
tz@771: 
cg@1986: resourceSelectorHolder
cg@1986:     "returns the value holder for the name of the selector"
cg@1986: 
cg@1986:     |holder|
cg@1986:     (holder := builder bindingAt:#valueOfResourceSelector) isNil ifTrue:[
cg@1986:         builder aspectAt:#valueOfResourceSelector put:(holder :=  '' asValue).
cg@1986:     ].
cg@1986:     ^ holder
cg@1986: !
cg@1986: 
tz@906: rootOfClassCategories
tz@906:     "returns the value holder for the root of the class tree list"
tz@906: 
tz@906:     |holder|                                
tz@906: 
tz@906:     (holder := builder bindingAt:#rootOfClassCategories) isNil ifTrue:[
tz@906:         ClassPresentation = #'Class Categories' ifTrue: [
tz@906:         builder aspectAt:#rootOfClassCategories put: (holder := TreeItem name: 'Categories')].
tz@906:     ].
tz@906:     ^ holder
tz@906: 
tz@906: 
tz@906: !
tz@906: 
tz@906: rootOfClassHierarchy
tz@771:     "returns the value holder for the root of the class tree list"
tz@771: 
tz@771:     |holder|
tz@906: 
tz@906: 
tz@906:     (holder := builder bindingAt:#rootOfClassHierarchy) isNil ifTrue:[
tz@906:         ClassPresentation = #'Class Hierarchy' ifTrue: [
tz@906:         builder aspectAt:#rootOfClassHierarchy put: (holder := TreeItem new)]
tz@425:     ].
tz@425:     ^ holder
tz@425: 
tz@425: 
tz@425: !
tz@425: 
tz@906: selectionOfClassCategories
tz@906:     "returns the value holder for the selected class of the class tree list"
tz@906: 
tz@906:     |holder|           
tz@906:     (holder := builder bindingAt:#selectionOfClassCategories) isNil ifTrue:[
tz@906:         builder aspectAt:#selectionOfClassCategories put:(holder :=  ValueHolder new). 
tz@906:     ].
tz@906:     ^ holder
tz@906: !
tz@906: 
tz@906: selectionOfClassHierarchy
tz@771:     "returns the value holder for the selected class of the class tree list"
tz@425: 
tz@906:     |holder|           
tz@906:     (holder := builder bindingAt:#selectionOfClassHierarchy) isNil ifTrue:[
tz@906:         builder aspectAt:#selectionOfClassHierarchy put:(holder :=  ValueHolder new). 
tz@906:     ].
tz@906:     ^ holder
tz@906: !
tz@906: 
tz@906: selectionOfClassPresentation
tz@906:     "returns the value holder for the selected class presentation"
tz@906: 
tz@425:     |holder|
cg@1034: 
tz@906:     (holder := builder bindingAt:#selectionOfClassPresentation) isNil ifTrue:[
tz@906:         builder aspectAt:#selectionOfClassPresentation put:(holder :=  RadioButtonGroup with: (ClassPresentation := ClassPresentation ? #'Class Categories')).
cg@1329:         holder onChangeEvaluate: 
cg@1034:             [
cg@1034:                  |hv comp newRoot|
cg@1034: 
cg@1034:                  hv := holder value.
cg@1034:                  ClassPresentation := hv.
cg@1034:                  hv = #'Class Hierarchy' ifTrue:[
cg@1034:                       comp := builder componentAt: #listOfClassHierarchyView.
cg@1034:                       newRoot := self rootOfClassHierarchy.  
cg@1034:                  ] ifFalse: [
cg@1034:                       comp := builder componentAt: #listOfClassCategoriesView.
cg@1034:                       newRoot := self rootOfClassCategories. 
cg@1034:                  ].
cg@1034:                  comp root:newRoot.
cg@1034:                  comp raise. 
cg@1986:                  classSelectionBlock value: self classNameHolder value
cg@1034:             ]
tz@425:     ].
tz@425:     ^ holder
tz@425: !
tz@425: 
tz@771: selectionOfResourceMethod
tz@771:     "returns the value holder for the selected resource method of the resource method list"
tz@425: 
tz@425:     |holder|
tz@771:     (holder := builder bindingAt:#selectionOfResourceMethod) isNil ifTrue:[
tz@771: 	builder aspectAt:#selectionOfResourceMethod put:(holder :=  '' asValue).
tz@425:     ].
tz@425:     ^ holder
tz@425: !
tz@425: 
tz@467: valueOfClassName
sv@2309:     <resource: #obsolete>
tz@771:     "returns the value holder for the name of the class"
tz@467: 
cg@1986:     self obsoleteMethodWarning:'stupid name - use #classNameHolder'.
cg@1986:     ^ self classNameHolder
tz@467: !
tz@467: 
tz@771: valueOfResourceSelector
sv@2309:     <resource: #obsolete>
tz@771:     "returns the value holder for the name of the selector"
tz@425: 
cg@1986:     self obsoleteMethodWarning:'stupid name - use #resourceSelectorHolder'.
cg@1986:     ^ self resourceSelectorHolder
tz@425: ! !
tz@425: 
cg@1720: !ResourceSelectionBrowser methodsFor:'callbacks-class list'!
tz@632: 
tz@906: treeViewClassCategoryChildren
tz@906:     "returns the children for the contents (class) of aTreeItem as a block"
tz@906: 
cg@1034:     "/ cg: tz's algorithm was very-very slow, 
cg@1034:     "/ (it enumerated classes hundreds of times,
cg@1034:     "/  leading to a square runtime behavior
cg@1034:     "/  - i.e. very slow scrolling )
cg@1034:     "/ Speed up things by caching facts while enumerating
cg@1034:     "/ classes once only.
cg@1034: 
cg@2760:     |topClass childrenPerCategory privateClasses|
cg@1034: 
cg@1034:     topClass := self treeViewClassHierarchyContents.
cg@1034:     privateClasses := IdentitySet new.
cg@1034: 
cg@1034:     childrenPerCategory := Dictionary new.
cg@2760: 
cg@2760:     topClass withAllSubclassesDo:[:cls |
cg@1034:         |cat set|
cg@1034: 
cg@1034:         cls isPrivate ifFalse:[
cg@1034:             cat := cls category.
cg@2908:             cat notNil ifTrue:[
cg@2908:                 set := childrenPerCategory at:cat ifAbsent:nil.
cg@2908:                 set isNil ifTrue:[
cg@2908:                     childrenPerCategory at:cat put:(set := IdentitySet new).
cg@2908:                 ].
cg@2908:                 set add:cls
cg@1034:             ].
cg@1034:         ] ifTrue:[
cg@1034:             privateClasses add:cls
cg@1034:         ]
cg@1034:     ].
cg@1034: 
cg@1034:     ^ [:aTreeItem|
cg@1034:         |cont children initialContents setOfCategories itemCategory setOfClasses|
cg@1034: 
cg@1034:         (cont := aTreeItem contents) isBehavior ifTrue:[
cg@1034:            children := privateClasses select:[:cls | cls owningClass == aTreeItem contents].
cg@1034:            children := children asSortedCollection: [:c1 :c2| c1 name <= c2 name].
cg@1732:            "/ children := children collect: [:child| TreeItem name: child name , ' (', child superclass name, ')' contents: child]
cg@1732:            children := children collect: [:child| TreeItem name:(child name) contents: child]
cg@1034:         ] ifFalse:[
cg@1034:             cont size == 0 ifTrue:[
cg@1034:                 setOfCategories := childrenPerCategory keys.
cg@1034:                 children := setOfCategories asSortedCollection.
cg@1034:                 children := children collect: [:nm | TreeItem name:nm contents:#Category]
cg@1034:             ] ifFalse:[
cg@1034:                 cont == #Category ifTrue:[
cg@1034:                     itemCategory := aTreeItem name.
cg@1034:                     setOfClasses := childrenPerCategory at:itemCategory ifAbsent:[Set new].
cg@1034:                     children := setOfClasses asOrderedCollection sort:[:c1 :c2 | c1 name <= c2 name].
cg@1034:                     children := children collect:[:child | TreeItem name:child name contents:child].
cg@1034:                 ] ifFalse:[
cg@1034:                     "/ huh ?
cg@1034:                     children := OrderedCollection new.
cg@1034:                 ]
cg@1034:             ].
cg@1034:         ].
cg@1034:         children
cg@1034:     ]
cg@2908: 
cg@2908:     "Modified: / 22-08-2012 / 19:44:59 / cg"
tz@906: !
tz@906: 
tz@906: treeViewClassCategoryIcon
tz@906:     "returns the icon for aTreeItem as a block"
tz@906: 
tz@906:     ^self class treeViewClassHierarchyIcon
tz@906: 
tz@906: 
tz@906: !
tz@906: 
tz@906: treeViewClassHierarchyContents
tz@771:     "returns the contents of the root of the class tree list"
tz@632: 
cg@802:     |cls|
tz@632: 
cg@802:     resourceSuperclass notNil ifTrue:[
cg@1978:         cls := Smalltalk classNamed: resourceSuperclass.
cg@802:     ].
cg@1034:     cls notNil ifTrue:[^ cls].
cg@1034:     ^ self class treeViewClassHierarchyContents
tz@771: !
tz@771: 
tz@771: validateDoubleClick: aTreeItem
tz@771:     "returns whether a class may be selected"
tz@771: 
cg@1034:     |cont|
cg@1034: 
cg@1034:     ^ (cont := aTreeItem contents) ~= '' 
cg@1034:       and: [cont ~~ self treeViewClassHierarchyContents]       
tz@771: 
tz@771: 
tz@771: 
tz@632: ! !
tz@632: 
cg@1720: !ResourceSelectionBrowser methodsFor:'callbacks-user'!
tz@425: 
tz@771: classSelected
tz@771:     "after a class selection, read the allowed resource methods of the selected class"
tz@730: 
cg@1732:     |sel|
tz@906: 
cg@1919:     ClassPresentation = #'Class Hierarchy'
cg@1732: "/        ifTrue:  [sel := self selectionOfClassHierarchy value]
cg@1919:         ifFalse: [sel := self selectionOfClassCategories value].
cg@1919: 
cg@1919:     sel notNil ifTrue:[
cg@1978:         resourceClass := sel.
cg@1919:     ].
cg@1732:     self updateResourceMethodList.
tz@425: !
tz@425: 
cg@1384: classSelectionUpdate:clsPattern
cg@1384:     |foundClass classes|  
cg@1384: 
cg@1384:     clsPattern notNil ifTrue:[
cg@1384:         foundClass := Smalltalk at:(clsPattern printString asSymbol).
cg@1384:     ].
cg@1384:     (foundClass isClass not or:[foundClass name ~= clsPattern])
cg@1732:     ifTrue: [
cg@1384:         classes := allClasses select: [:cls| cls name size >= clsPattern size].
cg@1732:         1 to: clsPattern size do: [:i|    
cg@1384:              classes := classes select: [:cls| (cls name at: i) == (clsPattern at: i)].
cg@1384:         ].    
sv@1835:         foundClass := classes at: 1 ifAbsent:[]. 
cg@1384:     ].          
cg@1732: 
cg@1732:     foundClass notNil ifTrue: [           
sv@1835:         foundClass := foundClass autoload.
cg@1978:         resourceClass := foundClass.
cg@1732: 
cg@1732:         ClassPresentation = #'Class Hierarchy' ifTrue: [
cg@1732:             |searchArgs nonSuperclasses hierItem|
cg@1732: 
cg@1732:             false "foundClass isPrivate"
cg@3198:                 ifFalse: [searchArgs := foundClass withAllSuperclasses reversed]
cg@3198:                 ifTrue:  [searchArgs := foundClass owningClass withAllSuperclasses reversed. 
cg@1978:                           searchArgs add: foundClass].                                  
cg@1384:             (nonSuperclasses := self treeViewClassHierarchyContents allSuperclasses) notNil 
cg@1384:                 ifTrue: [searchArgs := searchArgs reject: [:cls| nonSuperclasses includes: cls]].
cg@1384: 
cg@1732:             hierItem := self rootOfClassHierarchy detectChild:[:child :arg| child contents == arg] arguments:searchArgs.
cg@1732:             hierItem notNil ifTrue:[
cg@1732:                 self selectionOfClassHierarchy value:hierItem.
cg@1732:             ].
sv@1835:         ] ifFalse: [
cg@1732:             |searchArgs hierItem|
cg@1732: 
cg@1732:             false "foundClass isPrivate"
cg@1384:                 ifTrue:  [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass owningClass name with: foundClass name]
cg@1384:                 ifFalse: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass name].
cg@1384: 
cg@1732:             hierItem := self rootOfClassCategories detectChild:[:child :arg| (child name upTo: $ ) = arg] arguments:searchArgs.
cg@1732:             hierItem notNil ifTrue:[
cg@1732:                 self selectionOfClassCategories value: hierItem.
cg@1732:             ].
cg@1384:         ].
cg@1384:     ].
cg@1986:     self classNameHolder value: clsPattern.
cg@1919:     self updateResourceMethodList.
cg@1384: !
cg@1384: 
tz@425: resourceDoubleClicked
tz@771:     "after a double click on resource method, accept it and close"
tz@425: 
tz@425:     accept value: true.
cg@1034:     self closeRequest
tz@425: !
tz@425: 
tz@425: resourceSelected
tz@771:     "after a click on a resource method, set its selector into the field"
tz@425: 
tz@771:     self selectionOfResourceMethod value notNil
cg@1986:         ifTrue: [self resourceSelectorHolder value: self selectionOfResourceMethod value selector]
cg@1732: !
cg@1732: 
cg@1732: updateResourceMethodList
cg@1732:     "read the allowed resource methods of the selected class"
cg@1732: 
cg@1732:     |class className item|
cg@1732: 
cg@1978:     (class := resourceClass) isNil ifTrue:[
cg@1732:         ClassPresentation = #'Class Hierarchy'
cg@1732:             ifTrue:  [item := self selectionOfClassHierarchy value ]
cg@1732:             ifFalse: [item := self selectionOfClassCategories value ].
cg@1978: 
cg@1732:         item notNil ifTrue:[
cg@1732:             className := item name.
cg@1732:             class := Smalltalk at:className asSymbol
cg@1732:         ].
cg@1732:     ].
cg@1732: 
cg@1732:     class isNil ifTrue: [^self].
cg@1732: 
sr@2038:     className := class name."/class theNonMetaclass name
cg@1732: 
cg@1920:     self withWaitCursorDo:[
cg@1732:         |newContents|           
cg@1732: 
cg@1732:         resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes].
cg@1732: 
cg@1986:         self classNameHolder value: className.
cg@1732:         self class lastSelection: className.
cg@1732: 
cg@1732:         newContents := class class methodDictionary asOrderedCollection 
cg@1732:                        select: [:m | m resources notNil 
cg@1732:                                      and: [resourceTypes includes: m resourceType]
cg@1732:                                ].
cg@1732:         newContents := newContents sort:[:m1 :m2 | m1 selector < m2 selector].
cg@1732:         newContents := newContents collect:[:m| (ResourceMethod new method:m)].
cg@1732: 
cg@1732:         self listOfResourceMethods contents:newContents
cg@1732:                 .
cg@1732:     ]
tz@425: ! !
tz@425: 
tz@425: !ResourceSelectionBrowser methodsFor:'instance creation'!
tz@425: 
cg@1978: openOnSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes
cg@1978:     "opens a ResourceSelectionBrowser; return a Message-object or nil"
tz@425: 
cg@1978:     |selectedClass enteredClassName className cls|
tz@771: 
tz@517:     resourceMethod := aSelector.
tz@425:     resourceTypes := aResourceTypes.
tz@425:     resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol].
cg@802:     resourceClass := nil.
cg@802: 
cg@1978:     aClassOrClassName notNil ifTrue:[
cg@1978:         aClassOrClassName isClass ifTrue: [
cg@1978:             cls := aClassOrClassName. 
cg@1978:             resourceClass := aClassOrClassName
cg@1978:         ] ifFalse: [
cg@1978:             cls := Smalltalk classNamed: aClassOrClassName.
cg@1978:             cls notNil ifTrue:[
cg@1978:                 resourceClass := cls
cg@802:             ]
cg@1978:         ]
cg@1978:     ].            
cg@1986:     self resourceSelectorHolder value:(aSelector ? '').
tz@463:     self open.
tz@463: 
cg@1978:     (selectedClass := self selectionOfClassHierarchy value) isNil ifTrue:[
cg@1978:         (selectedClass := self selectionOfClassCategories value) isNil ifTrue:[
cg@1986:             (enteredClassName := self classNameHolder value) isNil ifTrue:[
cg@1086:                 accept value ifTrue:[
cg@1086:                     self warn:'No valid class selected/entered'.
cg@1086:                 ].
cg@1086:                 ^ nil
cg@1086:             ]
cg@1086:         ]
cg@1086:     ].
tz@693: 
cg@1978:     className := enteredClassName.    
cg@1978:     className isNil ifTrue:[
cg@1978:         className := selectedClass name
tz@425:     ].
cg@1978:     cls := Smalltalk classNamed:className.
cg@1978:     (cls isClass and:[accept value]) ifTrue:[            
cg@1986:         ^ Method::MethodWhoInfo class:cls selector:(self resourceSelectorHolder value)
cg@1086:     ].
cg@1086: 
cg@1086:     accept value ifTrue:[
cg@1086:         self warn:'No valid class selected/entered'.
cg@1086:     ].
cg@1086:     ^ nil
cg@802: 
cg@802:     "Modified: / 22.4.1998 / 14:51:03 / cg"
tz@425: ! !
tz@425: 
cg@1716: !ResourceSelectionBrowser methodsFor:'startup & release'!
tz@425: 
tz@623: postBuildWith:aBuilder
tz@771:     "after building and before opening,  
tz@906:      create a class selection block, an entry completion block for the class name field"
tz@623: 
tz@771:     |classSelection classNameInputField|
tz@906:      
tz@906:     allClasses := self treeViewClassHierarchyContents withAllSubclasses reject: [:cls| cls isPrivate].
cg@1978:     classSelection := resourceClass isNil ifTrue:[nil] ifFalse:[resourceClass name]. 
cg@802: 
cg@1978:     (classSelection isNil or:[ (Smalltalk classNamed: classSelection) isNil]) 
tz@689:         ifTrue: [classSelection :=  self class lastSelection].
cg@1732: "/    (classSelection isNil or:[Smalltalk at: classSelection]) isNil 
cg@1732: "/        ifTrue: [classSelection :=  self treeViewContents].
cg@802: 
cg@1384:     classSelectionBlock := [:clsPattern | self classSelectionUpdate:clsPattern].
cg@1986:     self classNameHolder value:classSelection.  
tz@771: 
cg@1920:     (classNameInputField := builder componentAt: #classNameInputField) 
cg@1920:         entryCompletionBlock:
cg@1920:             [:value|
cg@1920:                 |s what m|
cg@1920: 
cg@1920:                 s := classNameInputField contents withoutSpaces.
cg@1920:                 what := Smalltalk classnameCompletion:s inEnvironment:Smalltalk.
cg@1920:                 classNameInputField contents:what first.
cg@1920:                 (what at:2) size ~~ 1 ifTrue:[
cg@1920:                     classNameInputField device beep
cg@1920:                 ]
cg@1920: "/                |what oldClassName|
cg@1920: "/                oldClassName := classNameInputField contents.
cg@1920: "/                what := Smalltalk classnameCompletion: value withoutSpaces.
cg@1920: "/                classNameInputField contents:what first.
cg@1920: "/                oldClassName = classNameInputField contents ifTrue:[classNameInputField flash].
cg@1920: "/                classSelectionBlock value: classNameInputField contents
cg@1920:             ].
tz@771: 
cg@1986:     classSelectionBlock value: self classNameHolder value.
cg@1732:     self updateResourceMethodList.
tz@906:     self selectionOfResourceMethod value: (self listOfResourceMethods detect: [:m| m selector == resourceMethod] ifNone: nil).
tz@909: 
tz@909:     ^super postBuildWith:aBuilder
tz@910: !
tz@910: 
tz@910: postOpenWith:aBuilder
tz@910:     "after opening and if turned on make hierarchy view visible"
tz@910: 
tz@910:     ClassPresentation = #'Class Hierarchy'
tz@910:         ifTrue: [(builder componentAt: #listOfClassHierarchyView) raise].
tz@910: 
cg@2026:     super postOpenWith:aBuilder
tz@425: ! !
tz@425: 
tz@771: !ResourceSelectionBrowser::ResourceMethod methodsFor:'accessing'!
tz@523: 
tz@523: iconOn:aGC
tz@771:     "registers and returns an icon indicating the resource type"
tz@523: 
cg@1524:     |cls sel image imageKey|
cg@1524: 
tz@730:     self resourceType isNil ifTrue: [^nil].
cg@1524: 
cg@1524:     icon isNil ifTrue:[
frank@1412:         ((self resourceType = #image) or: [resourceType = #fileImage])
cg@1524:         ifTrue:[  
cg@1524:             cls := method mclass theNonMetaclass.
cg@1524:             sel := method selector.
cg@1524:         ] ifFalse: [
frank@1412:             cls := SystemBrowser.
frank@1412:             sel := (resourceType, 'Icon') asSymbol.
frank@1412:         ].
frank@1412:         imageKey := (cls name, sel) asSymbol.
frank@1412:         (icon := aGC registeredImageAt: imageKey) isNil
cg@1524:         ifTrue: [       
frank@1412:             image := cls perform: sel.
cg@1524:             (image extent y > 18) ifTrue: [         
frank@1412:                 image := image magnifiedBy: 18/image extent y
frank@1412:             ].
frank@1412:             aGC registerImage: image key: imageKey.
frank@1412:             icon := aGC registeredImageAt: imageKey.
frank@1412:         ].
tz@730:     ].
tz@523:     ^icon
cg@1524: 
cg@1524:     "Modified: / 5.11.2001 / 16:48:35 / cg"
tz@523: !
tz@523: 
tz@523: method: aMethod
tz@771:     "sets aMethod"
tz@523: 
tz@523:     method := aMethod
tz@523: !
tz@523: 
tz@523: resourceType
tz@771:     "returns resourceType"
tz@523: 
tz@523:     resourceType isNil ifTrue: [resourceType := method resourceType].
tz@523:     ^resourceType
tz@523: !
tz@523: 
tz@523: selector
tz@771:     "returns selector"
tz@523: 
tz@523:     selector isNil ifTrue: [selector := method who methodSelector].
tz@523:     ^selector
tz@523: ! !
tz@523: 
tz@425: !ResourceSelectionBrowser class methodsFor:'documentation'!
tz@425: 
tz@425: version
tz@425:     ^ '$Header$'
cg@2760: !
cg@2760: 
cg@2760: version_CVS
cg@2760:     ^ '$Header$'
tz@425: ! !
sv@3117: