ResourceSelectionBrowser.st
author Claus Gittinger <cg@exept.de>
Wed, 29 Jul 2009 20:02:02 +0200
changeset 2570 4e663bc64364
parent 2441 a0c5da242681
child 2760 11963b80d72c
permissions -rw-r--r--
changed #requestPackage
     1 "
     2  COPYRIGHT (c) 1997-1998 by eXept Software AG
     3               All Rights Reserved
     4 
     5  This software is furnished under a license and may be used
     6  only in accordance with the terms of that license and with the
     7  inclusion of the above copyright notice. This software may not
     8  be provided or otherwise made available to, or used by, any
     9  other person. No title to or ownership of the software is
    10  hereby transferred.
    11 "
    12 "{ Package: 'stx:libtool2' }"
    13 
    14 SelectionBrowser subclass:#ResourceSelectionBrowser
    15 	instanceVariableNames:'resourceMethod resourceClass resourceSuperclass resourceTypes
    16 		allClasses classSelectionBlock'
    17 	classVariableNames:'ClassPresentation'
    18 	poolDictionaries:''
    19 	category:'Interface-Dialogs'
    20 !
    21 
    22 Object subclass:#ResourceMethod
    23 	instanceVariableNames:'method icon resourceType selector'
    24 	classVariableNames:''
    25 	poolDictionaries:''
    26 	privateIn:ResourceSelectionBrowser
    27 !
    28 
    29 !ResourceSelectionBrowser class methodsFor:'documentation'!
    30 
    31 copyright
    32 "
    33  COPYRIGHT (c) 1997-1998 by eXept Software AG
    34               All Rights Reserved
    35 
    36  This software is furnished under a license and may be used
    37  only in accordance with the terms of that license and with the
    38  inclusion of the above copyright notice. This software may not
    39  be provided or otherwise made available to, or used by, any
    40  other person. No title to or ownership of the software is
    41  hereby transferred.
    42 "
    43 
    44 !
    45 
    46 documentation
    47 "
    48     The ResourceSelectionBrowser allows you to browse in class hierarchies
    49     and to select resource methods for loading or to saving resource 
    50     specifications (#canvas, #menu, etc.).
    51 
    52     [instance variables:]
    53         resourceMethod          <Symbol>        selector of the resource spec
    54         resourceClass           <Symbol>        class of the resource spec
    55         resourceSuperclass      <Symbol>        root class of the tree list
    56         resourceTypes           <Array>         allowed resource types
    57         allClasses              <Array>         list of the subclasses of resourceSuperclass
    58         classSelectionBlock     <Block>         by evaluating this block the class selection is done
    59 
    60     [start with:]
    61         ResourceSelectionBrowser open
    62 
    63     [author:]
    64         Thomas Zwick, eXept Software AG
    65 "
    66 ! !
    67 
    68 !ResourceSelectionBrowser class methodsFor:'instance creation'!
    69 
    70 request:aTitle onSuperclass:aSuperclass andClass:aClassOrClassName andSelector:aSelector withResourceTypes:resourceTypes
    71     "opens a ResourceSelectionBrowser; return a Message-object or nil."
    72 
    73     ^ (self new
    74         title: aTitle)
    75             openOnSuperclass:aSuperclass
    76             andClass:aClassOrClassName
    77             andSelector:aSelector
    78             withResourceTypes:resourceTypes
    79 
    80     "
    81      ResourceSelectionBrowser
    82         request: 'Select a Resource Selector'
    83         onSuperclass: #ApplicationModel 
    84         andClassNamed: #MenuEditor 
    85         andSelector: #menuItemImage 
    86         withResourceTypes: #(image) 
    87     "
    88 ! !
    89 
    90 !ResourceSelectionBrowser class methodsFor:'callbacks-default'!
    91 
    92 treeViewClassHierarchyChildren
    93     "returns the children for the contents (class) of aTreeItem as a block"
    94 
    95     "/ cg: tz's algorithm was very-very slow, 
    96     "/ (it enumerated classes hundreds of times,
    97     "/  leading to a square runtime behavior
    98     "/  - i.e. very slow scrolling )
    99     "/ Speed up things by caching facts while enumerating
   100     "/ classes once only.
   101 
   102     |subclassesAndPrivateClassesPerClass|
   103 
   104     subclassesAndPrivateClassesPerClass := IdentityDictionary new.
   105 
   106     Smalltalk allClassesDo:[:cls |
   107         |owner superclass info|
   108 
   109 "/        (owner := cls owningClass) notNil ifTrue:[
   110 "/            info := subclassesAndPrivateClassesPerClass at:owner ifAbsent:nil.
   111 "/            info isNil ifTrue:[
   112 "/                subclassesAndPrivateClassesPerClass at:owner put:(info := Array with:IdentitySet new 
   113 "/                                                                                with:IdentitySet new).
   114 "/            ].
   115 "/            (info at:2) add:cls
   116 "/        ] ifFalse:[
   117             superclass := cls superclass.
   118             superclass notNil ifTrue:[
   119                 info := subclassesAndPrivateClassesPerClass at:superclass ifAbsent:nil.
   120                 info isNil ifTrue:[
   121                     subclassesAndPrivateClassesPerClass at:superclass put:(info := Array with:IdentitySet new 
   122                                                                                          with:IdentitySet new).
   123                 ].
   124                 (info at:1) add:cls
   125             ]
   126 "/        ]
   127     ].
   128 
   129     ^ [:aTreeItem|
   130         |classes itemClass info|
   131 
   132         classes := OrderedCollection new. 
   133         itemClass := aTreeItem contents.
   134         info := subclassesAndPrivateClassesPerClass at:itemClass ifAbsent:nil.
   135         info notNil ifTrue:[
   136             classes addAll:((info at:1) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]).
   137             classes addAll:((info at:2) asSortedCollection: [:cls1 :cls2| cls1 name < cls2 name]).
   138         ].
   139         classes
   140      ]
   141 !
   142 
   143 treeViewClassHierarchyContents
   144     "returns the default contents of the root of the class tree list"
   145 
   146     ^ Object
   147 
   148 !
   149 
   150 treeViewClassHierarchyIcon
   151     "returns the icon for aTreeItem as a block"
   152 
   153     ^[:aTreeItem|
   154         |icon|
   155 
   156         aTreeItem contents isClass ifTrue:[
   157             icon := self iconClass.
   158             aTreeItem contents isPrivate ifTrue:[
   159                icon := self iconPrivateClass
   160             ].
   161             icon
   162         ] ifFalse:[
   163             self iconCategory
   164         ]
   165     ]
   166 
   167 !
   168 
   169 treeViewClassHierarchyLabel
   170     "returns the label for aTreeItem as a block"
   171 
   172     ^[:aTreeItem|
   173         |label superCls itemContents|
   174 
   175         itemContents := aTreeItem contents.
   176         label := itemContents name.
   177 "/        (itemContents isPrivate 
   178 "/        and:[aTreeItem parent contents ~~ (superCls := itemContents superclass)])
   179 "/            ifTrue: [label := label, ' (', superCls name, ')'].
   180         label
   181      ]
   182 ! !
   183 
   184 !ResourceSelectionBrowser class methodsFor:'image specs'!
   185 
   186 iconCategory
   187     "This resource specification was automatically generated
   188      by the ImageEditor of ST/X."
   189 
   190     "Do not manually edit this!! If it is corrupted,
   191      the ImageEditor may not be able to read the specification."
   192 
   193     "
   194      self iconCategory inspect
   195      ImageEditor openOnClass:self andSelector:#iconCategory
   196     "
   197 
   198     <resource: #image>
   199 
   200     ^Icon
   201         constantNamed:#'ResourceSelectionBrowser class iconCategory'
   202         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:((Depth1Image new) width: 18; height: 16; photometric:(#blackIs0); bitsPerSample:(#(1 )); samplesPerPixel:(1); 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]
   203 !
   204 
   205 iconClass
   206     "This resource specification was automatically generated
   207      by the ImageEditor of ST/X."
   208 
   209     "Do not manually edit this!! If it is corrupted,
   210      the ImageEditor may not be able to read the specification."
   211 
   212     "
   213      self iconClass inspect
   214      ImageEditor openOnClass:self andSelector:#iconClass
   215     "
   216 
   217     <resource: #image>
   218 
   219     ^Icon
   220         constantNamed:#'ResourceSelectionBrowser class iconClass'
   221         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:((Depth1Image new) width: 18; height: 16; photometric:(#blackIs0); bitsPerSample:(#(1 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@') ; yourself); yourself]
   222 !
   223 
   224 iconPrivateClass
   225     "This resource specification was automatically generated
   226      by the ImageEditor of ST/X."
   227 
   228     "Do not manually edit this!! If it is corrupted,
   229      the ImageEditor may not be able to read the specification."
   230 
   231     "
   232      ImageEditor openOnClass:self andSelector:#iconPrivateClass
   233     "
   234 
   235     <resource: #image>
   236 
   237     ^Icon
   238         constantNamed:#'ResourceSelectionBrowser class iconPrivateClass'
   239         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:((Depth1Image new) width: 18; height: 16; photometric:(#blackIs0); bitsPerSample:(#(1 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'_?>@???@???@???@???@???@???@???@???@???@???@???@???@???@???@_?>@') ; yourself); yourself]
   240 ! !
   241 
   242 !ResourceSelectionBrowser class methodsFor:'interface specs'!
   243 
   244 windowSpec
   245     "This resource specification was automatically generated
   246      by the UIPainter of ST/X."
   247 
   248     "Do not manually edit this!! If it is corrupted,
   249      the UIPainter may not be able to read the specification."
   250 
   251     "
   252      UIPainter new openOnClass:ResourceSelectionBrowser andSelector:#windowSpec
   253      ResourceSelectionBrowser new openInterface:#windowSpec
   254      ResourceSelectionBrowser open
   255     "
   256 
   257     <resource: #canvas>
   258 
   259     ^ 
   260      #(FullSpec
   261         name: windowSpec
   262         window: 
   263        (WindowSpec
   264           label: 'Resource Selection Browser'
   265           name: 'Resource Selection Browser'
   266           min: (Point 400 300)
   267           max: (Point 1152 864)
   268           bounds: (Rectangle 12 22 612 372)
   269         )
   270         component: 
   271        (SpecCollection
   272           collection: (
   273            (VariableHorizontalPanelSpec
   274               name: 'VariableHorizontalPanel'
   275               layout: (LayoutFrame 0 0.0 0 0.0 0 1.0 -36 1.0)
   276               component: 
   277              (SpecCollection
   278                 collection: (
   279                  (ViewSpec
   280                     name: 'Box1'
   281                     component: 
   282                    (SpecCollection
   283                       collection: (
   284                        (HorizontalPanelViewSpec
   285                           name: 'HorizontalPanel2'
   286                           layout: (LayoutFrame 0 0 2 0 297 0 23 0)
   287                           horizontalLayout: leftSpace
   288                           verticalLayout: fit
   289                           horizontalSpace: 3
   290                           verticalSpace: 3
   291                           component: 
   292                          (SpecCollection
   293                             collection: (
   294                              (RadioButtonSpec
   295                                 label: 'Categories'
   296                                 name: 'ClassCategoriesRadioButton'
   297                                 translateLabel: true
   298                                 model: selectionOfClassPresentation
   299                                 isTriggerOnDown: true
   300                                 lampColor: (Color 0.0 0.0 0.0)
   301                                 select: #'Class Categories'
   302                                 extent: (Point 124 21)
   303                               )
   304                              (RadioButtonSpec
   305                                 label: 'Hierarchy'
   306                                 name: 'ClassHierarchyRadioButton'
   307                                 translateLabel: true
   308                                 model: selectionOfClassPresentation
   309                                 isTriggerOnDown: true
   310                                 lampColor: (Color 0.0 0.0 0.0)
   311                                 select: #'Class Hierarchy'
   312                                 extent: (Point 145 21)
   313                               )
   314                              )
   315                            
   316                           )
   317                         )
   318                        (SelectionInTreeViewSpec
   319                           name: 'listOfClassHierarchyView'
   320                           layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0)
   321                           tabable: true
   322                           model: selectionOfClassHierarchy
   323                           hasHorizontalScrollBar: true
   324                           hasVerticalScrollBar: true
   325                           miniScrollerHorizontal: true
   326                           showDirectoryIndicatorForRoot: false
   327                           showDirectoryIndicator: true
   328                           valueChangeSelector: classSelected
   329                           hierarchicalList: rootOfClassHierarchy
   330                           validateDoubleClickSelector: validateDoubleClick:
   331                           contentsSelector: treeViewClassHierarchyContents
   332                           labelSelector: treeViewClassHierarchyLabel
   333                           childrenSelector: treeViewClassHierarchyChildren
   334                           iconSelector: treeViewClassHierarchyIcon
   335                           highlightMode: line
   336                         )
   337                        (SelectionInTreeViewSpec
   338                           name: 'listOfClassCategoriesView'
   339                           layout: (LayoutFrame 0 0.0 23 0.0 0 1.0 -24 1.0)
   340                           tabable: true
   341                           model: selectionOfClassCategories
   342                           hasHorizontalScrollBar: true
   343                           hasVerticalScrollBar: true
   344                           miniScrollerHorizontal: true
   345                           showRoot: false
   346                           showDirectoryIndicator: true
   347                           valueChangeSelector: classSelected
   348                           hierarchicalList: rootOfClassCategories
   349                           validateDoubleClickSelector: validateDoubleClick:
   350                           childrenSelector: treeViewClassCategoryChildren
   351                           iconSelector: treeViewClassCategoryIcon
   352                           highlightMode: line
   353                         )
   354                        (InputFieldSpec
   355                           name: 'classNameInputField'
   356                           layout: (LayoutFrame 2 0.0 -22 1 -1 1.0 0 1)
   357                           tabable: true
   358                           model: classNameHolder
   359                           acceptOnLeave: true
   360                           acceptOnLostFocus: true
   361                           acceptOnPointerLeave: true
   362                         )
   363                        )
   364                      
   365                     )
   366                   )
   367                  (ViewSpec
   368                     name: 'Box2'
   369                     component: 
   370                    (SpecCollection
   371                       collection: (
   372                        (DataSetSpec
   373                           name: 'resourcesDataSetView'
   374                           layout: (LayoutFrame 2 0.0 2 0.0 -2 1.0 -24 1.0)
   375                           model: selectionOfResourceMethod
   376                           hasHorizontalScrollBar: true
   377                           hasVerticalScrollBar: true
   378                           miniScrollerHorizontal: true
   379                           rowClassName: 'ResourceSelectionBrowser::Row'
   380                           dataList: listOfResourceMethods
   381                           useIndex: false
   382                           has3Dsepartors: true
   383                           has3Dseparators: true
   384                           doubleClickSelector: resourceDoubleClicked
   385                           columnHolder: resourceMethodColumns
   386                           valueChangeSelector: resourceSelected
   387                           verticalSpacing: 1
   388                         )
   389                        (InputFieldSpec
   390                           name: 'selectorInputField'
   391                           layout: (LayoutFrame 2 0.0 -22 1 -2 1.0 0 1)
   392                           tabable: true
   393                           model: resourceSelectorHolder
   394                           acceptOnLeave: true
   395                           acceptOnLostFocus: true
   396                           acceptOnPointerLeave: true
   397                         )
   398                        )
   399                      
   400                     )
   401                   )
   402                  )
   403                
   404               )
   405               handles: (Any 0.5 1.0)
   406             )
   407            (HorizontalPanelViewSpec
   408               name: 'ButtonPanel'
   409               layout: (LayoutFrame 2 0.0 -30 1 -2 1.0 -4 1.0)
   410               horizontalLayout: fit
   411               verticalLayout: fit
   412               reverseOrderIfOKAtLeft: true
   413               component: 
   414              (SpecCollection
   415                 collection: (
   416                  (ActionButtonSpec
   417                     label: 'Help'
   418                     name: 'HelpButton'
   419                     activeHelpKey: dss
   420                     model: openHTMLDocument:
   421                     initiallyDisabled: true
   422                     enableChannel: helpEnabled
   423                     actionValue: 'tools/uipainter/ResourceSelectionBrowser.html'
   424                     extent: (Point 196 26)
   425                   )
   426                  (ActionButtonSpec
   427                     label: 'Cancel'
   428                     name: 'cancelButton'
   429                     activeHelpKey: commitCancel
   430                     tabable: true
   431                     model: cancel
   432                     extent: (Point 197 26)
   433                   )
   434                  (ActionButtonSpec
   435                     label: 'OK'
   436                     name: 'okButton'
   437                     activeHelpKey: commitOK
   438                     tabable: true
   439                     model: accept
   440                     isDefault: true
   441                     extent: (Point 197 26)
   442                   )
   443                  )
   444                
   445               )
   446             )
   447            )
   448          
   449         )
   450       )
   451 ! !
   452 
   453 !ResourceSelectionBrowser class methodsFor:'list specs'!
   454 
   455 tableColumnsForResourceMethodAttributes
   456     "This resource specification was automatically generated
   457      by the DataSetBuilder of ST/X."
   458 
   459     "Do not manually edit this!! If it is corrupted,
   460      the DataSetBuilder may not be able to read the specification."
   461 
   462     "
   463      DataSetBuilder new openOnClass:ResourceSelectionBrowser andSelector:#tableColumnsForResourceMethodAttributes
   464     "
   465 
   466     <resource: #tableColumns>
   467 
   468 
   469     ^ #(
   470         #(#DataSetColumnSpec
   471            #width: 20
   472            #height: 20
   473            #printSelector: #iconOn:
   474            #canSelect: false
   475        )
   476         #(#DataSetColumnSpec
   477            #label: ' Selector'
   478            #labelAlignment: #left
   479            #model: #selector
   480            #canSelect: false
   481        )
   482         #(#DataSetColumnSpec
   483            #label: ' Resource Type'
   484            #labelAlignment: #left
   485            #model: #resourceType
   486            #canSelect: false
   487        )
   488      )
   489 ! !
   490 
   491 !ResourceSelectionBrowser methodsFor:'aspects'!
   492 
   493 classNameHolder
   494     "returns the value holder for the name of the class"
   495 
   496     |holder|
   497 
   498     (holder := builder bindingAt:#valueOfClassName) isNil ifTrue:[
   499         builder aspectAt:#valueOfClassName put:(holder :=  '' asValue).
   500         holder onChangeEvaluate:[self classSelectionUpdate:holder value].
   501     ].
   502     ^ holder
   503 !
   504 
   505 helpEnabled
   506     "returns whether there is a documentation file"
   507 
   508     ^true
   509 !
   510 
   511 listOfResourceMethods
   512     "returns the value holder for the list of the resource methods"
   513 
   514     ^ builder listAspectFor:#listOfResourceMethods
   515 !
   516 
   517 resourceMethodColumns
   518     "returns the columns for the table of the resource methods as value holder"
   519 
   520     |holder|
   521     (holder := builder bindingAt:#resourceMethodColumns) isNil ifTrue:[
   522         builder aspectAt:#resourceMethodColumns put:(holder := List new).
   523         holder addAll: (self class tableColumnsForResourceMethodAttributes collect: [:i| i decodeAsLiteralArray]).
   524     ].
   525     ^ holder
   526 !
   527 
   528 resourceSelectorHolder
   529     "returns the value holder for the name of the selector"
   530 
   531     |holder|
   532     (holder := builder bindingAt:#valueOfResourceSelector) isNil ifTrue:[
   533         builder aspectAt:#valueOfResourceSelector put:(holder :=  '' asValue).
   534     ].
   535     ^ holder
   536 !
   537 
   538 rootOfClassCategories
   539     "returns the value holder for the root of the class tree list"
   540 
   541     |holder|                                
   542 
   543     (holder := builder bindingAt:#rootOfClassCategories) isNil ifTrue:[
   544         ClassPresentation = #'Class Categories' ifTrue: [
   545         builder aspectAt:#rootOfClassCategories put: (holder := TreeItem name: 'Categories')].
   546     ].
   547     ^ holder
   548 
   549 
   550 !
   551 
   552 rootOfClassHierarchy
   553     "returns the value holder for the root of the class tree list"
   554 
   555     |holder|
   556 
   557 
   558     (holder := builder bindingAt:#rootOfClassHierarchy) isNil ifTrue:[
   559         ClassPresentation = #'Class Hierarchy' ifTrue: [
   560         builder aspectAt:#rootOfClassHierarchy put: (holder := TreeItem new)]
   561     ].
   562     ^ holder
   563 
   564 
   565 !
   566 
   567 selectionOfClassCategories
   568     "returns the value holder for the selected class of the class tree list"
   569 
   570     |holder|           
   571     (holder := builder bindingAt:#selectionOfClassCategories) isNil ifTrue:[
   572         builder aspectAt:#selectionOfClassCategories put:(holder :=  ValueHolder new). 
   573     ].
   574     ^ holder
   575 !
   576 
   577 selectionOfClassHierarchy
   578     "returns the value holder for the selected class of the class tree list"
   579 
   580     |holder|           
   581     (holder := builder bindingAt:#selectionOfClassHierarchy) isNil ifTrue:[
   582         builder aspectAt:#selectionOfClassHierarchy put:(holder :=  ValueHolder new). 
   583     ].
   584     ^ holder
   585 !
   586 
   587 selectionOfClassPresentation
   588     "returns the value holder for the selected class presentation"
   589 
   590     |holder|
   591 
   592     (holder := builder bindingAt:#selectionOfClassPresentation) isNil ifTrue:[
   593         builder aspectAt:#selectionOfClassPresentation put:(holder :=  RadioButtonGroup with: (ClassPresentation := ClassPresentation ? #'Class Categories')).
   594         holder onChangeEvaluate: 
   595             [
   596                  |hv comp newRoot|
   597 
   598                  hv := holder value.
   599                  ClassPresentation := hv.
   600                  hv = #'Class Hierarchy' ifTrue:[
   601                       comp := builder componentAt: #listOfClassHierarchyView.
   602                       newRoot := self rootOfClassHierarchy.  
   603                  ] ifFalse: [
   604                       comp := builder componentAt: #listOfClassCategoriesView.
   605                       newRoot := self rootOfClassCategories. 
   606                  ].
   607                  comp root:newRoot.
   608                  comp raise. 
   609                  classSelectionBlock value: self classNameHolder value
   610             ]
   611     ].
   612     ^ holder
   613 !
   614 
   615 selectionOfResourceMethod
   616     "returns the value holder for the selected resource method of the resource method list"
   617 
   618     |holder|
   619     (holder := builder bindingAt:#selectionOfResourceMethod) isNil ifTrue:[
   620 	builder aspectAt:#selectionOfResourceMethod put:(holder :=  '' asValue).
   621     ].
   622     ^ holder
   623 !
   624 
   625 valueOfClassName
   626     <resource: #obsolete>
   627     "returns the value holder for the name of the class"
   628 
   629     self obsoleteMethodWarning:'stupid name - use #classNameHolder'.
   630     ^ self classNameHolder
   631 !
   632 
   633 valueOfResourceSelector
   634     <resource: #obsolete>
   635     "returns the value holder for the name of the selector"
   636 
   637     self obsoleteMethodWarning:'stupid name - use #resourceSelectorHolder'.
   638     ^ self resourceSelectorHolder
   639 ! !
   640 
   641 !ResourceSelectionBrowser methodsFor:'callbacks-class list'!
   642 
   643 treeViewClassCategoryChildren
   644     "returns the children for the contents (class) of aTreeItem as a block"
   645 
   646     "/ cg: tz's algorithm was very-very slow, 
   647     "/ (it enumerated classes hundreds of times,
   648     "/  leading to a square runtime behavior
   649     "/  - i.e. very slow scrolling )
   650     "/ Speed up things by caching facts while enumerating
   651     "/ classes once only.
   652 
   653     |allClasses topClass childrenPerCategory privateClasses|
   654 
   655     topClass := self treeViewClassHierarchyContents.
   656     allClasses := topClass withAllSubclasses.
   657     privateClasses := IdentitySet new.
   658 
   659     childrenPerCategory := Dictionary new.
   660     allClasses do:[:cls |
   661         |cat set|
   662 
   663         cls isPrivate ifFalse:[
   664             cat := cls category.
   665             set := childrenPerCategory at:cat ifAbsent:nil.
   666             set isNil ifTrue:[
   667                 childrenPerCategory at:cat put:(set := IdentitySet new).
   668             ].
   669             set add:cls
   670         ] ifTrue:[
   671             privateClasses add:cls
   672         ]
   673     ].
   674 
   675     ^ [:aTreeItem|
   676         |cont children initialContents setOfCategories itemCategory setOfClasses|
   677 
   678         (cont := aTreeItem contents) isBehavior ifTrue:[
   679            children := privateClasses select:[:cls | cls owningClass == aTreeItem contents].
   680            children := children asSortedCollection: [:c1 :c2| c1 name <= c2 name].
   681            "/ children := children collect: [:child| TreeItem name: child name , ' (', child superclass name, ')' contents: child]
   682            children := children collect: [:child| TreeItem name:(child name) contents: child]
   683         ] ifFalse:[
   684             cont size == 0 ifTrue:[
   685                 setOfCategories := childrenPerCategory keys.
   686                 children := setOfCategories asSortedCollection.
   687                 children := children collect: [:nm | TreeItem name:nm contents:#Category]
   688             ] ifFalse:[
   689                 cont == #Category ifTrue:[
   690                     itemCategory := aTreeItem name.
   691                     setOfClasses := childrenPerCategory at:itemCategory ifAbsent:[Set new].
   692                     children := setOfClasses asOrderedCollection sort:[:c1 :c2 | c1 name <= c2 name].
   693                     children := children collect:[:child | TreeItem name:child name contents:child].
   694                 ] ifFalse:[
   695                     "/ huh ?
   696                     children := OrderedCollection new.
   697                 ]
   698             ].
   699         ].
   700         children
   701     ]
   702 !
   703 
   704 treeViewClassCategoryIcon
   705     "returns the icon for aTreeItem as a block"
   706 
   707     ^self class treeViewClassHierarchyIcon
   708 
   709 
   710 !
   711 
   712 treeViewClassHierarchyContents
   713     "returns the contents of the root of the class tree list"
   714 
   715     |cls|
   716 
   717     resourceSuperclass notNil ifTrue:[
   718         cls := Smalltalk classNamed: resourceSuperclass.
   719     ].
   720     cls notNil ifTrue:[^ cls].
   721     ^ self class treeViewClassHierarchyContents
   722 !
   723 
   724 validateDoubleClick: aTreeItem
   725     "returns whether a class may be selected"
   726 
   727     |cont|
   728 
   729     ^ (cont := aTreeItem contents) ~= '' 
   730       and: [cont ~~ self treeViewClassHierarchyContents]       
   731 
   732 
   733 
   734 ! !
   735 
   736 !ResourceSelectionBrowser methodsFor:'callbacks-user'!
   737 
   738 classSelected
   739     "after a class selection, read the allowed resource methods of the selected class"
   740 
   741     |sel|
   742 
   743     ClassPresentation = #'Class Hierarchy'
   744 "/        ifTrue:  [sel := self selectionOfClassHierarchy value]
   745         ifFalse: [sel := self selectionOfClassCategories value].
   746 
   747     sel notNil ifTrue:[
   748         resourceClass := sel.
   749     ].
   750     self updateResourceMethodList.
   751 !
   752 
   753 classSelectionUpdate:clsPattern
   754     |foundClass classes|  
   755 
   756     clsPattern notNil ifTrue:[
   757         foundClass := Smalltalk at:(clsPattern printString asSymbol).
   758     ].
   759     (foundClass isClass not or:[foundClass name ~= clsPattern])
   760     ifTrue: [
   761         classes := allClasses select: [:cls| cls name size >= clsPattern size].
   762         1 to: clsPattern size do: [:i|    
   763              classes := classes select: [:cls| (cls name at: i) == (clsPattern at: i)].
   764         ].    
   765         foundClass := classes at: 1 ifAbsent:[]. 
   766     ].          
   767 
   768     foundClass notNil ifTrue: [           
   769         foundClass := foundClass autoload.
   770         resourceClass := foundClass.
   771 
   772         ClassPresentation = #'Class Hierarchy' ifTrue: [
   773             |searchArgs nonSuperclasses hierItem|
   774 
   775             false "foundClass isPrivate"
   776                 ifFalse: [searchArgs := foundClass withAllSuperclasses reverse]
   777                 ifTrue:  [searchArgs := foundClass owningClass withAllSuperclasses reverse. 
   778                           searchArgs add: foundClass].                                  
   779             (nonSuperclasses := self treeViewClassHierarchyContents allSuperclasses) notNil 
   780                 ifTrue: [searchArgs := searchArgs reject: [:cls| nonSuperclasses includes: cls]].
   781 
   782             hierItem := self rootOfClassHierarchy detectChild:[:child :arg| child contents == arg] arguments:searchArgs.
   783             hierItem notNil ifTrue:[
   784                 self selectionOfClassHierarchy value:hierItem.
   785             ].
   786         ] ifFalse: [
   787             |searchArgs hierItem|
   788 
   789             false "foundClass isPrivate"
   790                 ifTrue:  [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass owningClass name with: foundClass name]
   791                 ifFalse: [searchArgs := Array with: 'Categories' with: foundClass category with: foundClass name].
   792 
   793             hierItem := self rootOfClassCategories detectChild:[:child :arg| (child name upTo: $ ) = arg] arguments:searchArgs.
   794             hierItem notNil ifTrue:[
   795                 self selectionOfClassCategories value: hierItem.
   796             ].
   797         ].
   798     ].
   799     self classNameHolder value: clsPattern.
   800     self updateResourceMethodList.
   801 !
   802 
   803 resourceDoubleClicked
   804     "after a double click on resource method, accept it and close"
   805 
   806     accept value: true.
   807     self closeRequest
   808 !
   809 
   810 resourceSelected
   811     "after a click on a resource method, set its selector into the field"
   812 
   813     self selectionOfResourceMethod value notNil
   814         ifTrue: [self resourceSelectorHolder value: self selectionOfResourceMethod value selector]
   815 !
   816 
   817 updateResourceMethodList
   818     "read the allowed resource methods of the selected class"
   819 
   820     |class className item|
   821 
   822     (class := resourceClass) isNil ifTrue:[
   823         ClassPresentation = #'Class Hierarchy'
   824             ifTrue:  [item := self selectionOfClassHierarchy value ]
   825             ifFalse: [item := self selectionOfClassCategories value ].
   826 
   827         item notNil ifTrue:[
   828             className := item name.
   829             class := Smalltalk at:className asSymbol
   830         ].
   831     ].
   832 
   833     class isNil ifTrue: [^self].
   834 
   835     className := class name."/class theNonMetaclass name
   836 
   837     self withWaitCursorDo:[
   838         |newContents|           
   839 
   840         resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes].
   841 
   842         self classNameHolder value: className.
   843         self class lastSelection: className.
   844 
   845         newContents := class class methodDictionary asOrderedCollection 
   846                        select: [:m | m resources notNil 
   847                                      and: [resourceTypes includes: m resourceType]
   848                                ].
   849         newContents := newContents sort:[:m1 :m2 | m1 selector < m2 selector].
   850         newContents := newContents collect:[:m| (ResourceMethod new method:m)].
   851 
   852         self listOfResourceMethods contents:newContents
   853                 .
   854     ]
   855 ! !
   856 
   857 !ResourceSelectionBrowser methodsFor:'instance creation'!
   858 
   859 openOnSuperclass: aSuperclassOrSymbol andClass:aClassOrClassName andSelector: aSelector withResourceTypes: aResourceTypes
   860     "opens a ResourceSelectionBrowser; return a Message-object or nil"
   861 
   862     |selectedClass enteredClassName className cls|
   863 
   864     resourceMethod := aSelector.
   865     resourceTypes := aResourceTypes.
   866     resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol].
   867     resourceClass := nil.
   868 
   869     aClassOrClassName notNil ifTrue:[
   870         aClassOrClassName isClass ifTrue: [
   871             cls := aClassOrClassName. 
   872             resourceClass := aClassOrClassName
   873         ] ifFalse: [
   874             cls := Smalltalk classNamed: aClassOrClassName.
   875             cls notNil ifTrue:[
   876                 resourceClass := cls
   877             ]
   878         ]
   879     ].            
   880     self resourceSelectorHolder value:(aSelector ? '').
   881     self open.
   882 
   883     (selectedClass := self selectionOfClassHierarchy value) isNil ifTrue:[
   884         (selectedClass := self selectionOfClassCategories value) isNil ifTrue:[
   885             (enteredClassName := self classNameHolder value) isNil ifTrue:[
   886                 accept value ifTrue:[
   887                     self warn:'No valid class selected/entered'.
   888                 ].
   889                 ^ nil
   890             ]
   891         ]
   892     ].
   893 
   894     className := enteredClassName.    
   895     className isNil ifTrue:[
   896         className := selectedClass name
   897     ].
   898     cls := Smalltalk classNamed:className.
   899     (cls isClass and:[accept value]) ifTrue:[            
   900         ^ Method::MethodWhoInfo class:cls selector:(self resourceSelectorHolder value)
   901     ].
   902 
   903     accept value ifTrue:[
   904         self warn:'No valid class selected/entered'.
   905     ].
   906     ^ nil
   907 
   908     "Modified: / 22.4.1998 / 14:51:03 / cg"
   909 ! !
   910 
   911 !ResourceSelectionBrowser methodsFor:'startup & release'!
   912 
   913 postBuildWith:aBuilder
   914     "after building and before opening,  
   915      create a class selection block, an entry completion block for the class name field"
   916 
   917     |classSelection classNameInputField|
   918      
   919     allClasses := self treeViewClassHierarchyContents withAllSubclasses reject: [:cls| cls isPrivate].
   920     classSelection := resourceClass isNil ifTrue:[nil] ifFalse:[resourceClass name]. 
   921 
   922     (classSelection isNil or:[ (Smalltalk classNamed: classSelection) isNil]) 
   923         ifTrue: [classSelection :=  self class lastSelection].
   924 "/    (classSelection isNil or:[Smalltalk at: classSelection]) isNil 
   925 "/        ifTrue: [classSelection :=  self treeViewContents].
   926 
   927     classSelectionBlock := [:clsPattern | self classSelectionUpdate:clsPattern].
   928     self classNameHolder value:classSelection.  
   929 
   930     (classNameInputField := builder componentAt: #classNameInputField) 
   931         entryCompletionBlock:
   932             [:value|
   933                 |s what m|
   934 
   935                 s := classNameInputField contents withoutSpaces.
   936                 what := Smalltalk classnameCompletion:s inEnvironment:Smalltalk.
   937                 classNameInputField contents:what first.
   938                 (what at:2) size ~~ 1 ifTrue:[
   939                     classNameInputField device beep
   940                 ]
   941 "/                |what oldClassName|
   942 "/                oldClassName := classNameInputField contents.
   943 "/                what := Smalltalk classnameCompletion: value withoutSpaces.
   944 "/                classNameInputField contents:what first.
   945 "/                oldClassName = classNameInputField contents ifTrue:[classNameInputField flash].
   946 "/                classSelectionBlock value: classNameInputField contents
   947             ].
   948 
   949     classSelectionBlock value: self classNameHolder value.
   950     self updateResourceMethodList.
   951     self selectionOfResourceMethod value: (self listOfResourceMethods detect: [:m| m selector == resourceMethod] ifNone: nil).
   952 
   953     ^super postBuildWith:aBuilder
   954 !
   955 
   956 postOpenWith:aBuilder
   957     "after opening and if turned on make hierarchy view visible"
   958 
   959     ClassPresentation = #'Class Hierarchy'
   960         ifTrue: [(builder componentAt: #listOfClassHierarchyView) raise].
   961 
   962     super postOpenWith:aBuilder
   963 ! !
   964 
   965 !ResourceSelectionBrowser::ResourceMethod methodsFor:'accessing'!
   966 
   967 iconOn:aGC
   968     "registers and returns an icon indicating the resource type"
   969 
   970     |cls sel image imageKey|
   971 
   972     self resourceType isNil ifTrue: [^nil].
   973 
   974     icon isNil ifTrue:[
   975         ((self resourceType = #image) or: [resourceType = #fileImage])
   976         ifTrue:[  
   977             cls := method mclass theNonMetaclass.
   978             sel := method selector.
   979         ] ifFalse: [
   980             cls := SystemBrowser.
   981             sel := (resourceType, 'Icon') asSymbol.
   982         ].
   983         imageKey := (cls name, sel) asSymbol.
   984         (icon := aGC registeredImageAt: imageKey) isNil
   985         ifTrue: [       
   986             image := cls perform: sel.
   987             (image extent y > 18) ifTrue: [         
   988                 image := image magnifiedBy: 18/image extent y
   989             ].
   990             aGC registerImage: image key: imageKey.
   991             icon := aGC registeredImageAt: imageKey.
   992         ].
   993     ].
   994     ^icon
   995 
   996     "Modified: / 5.11.2001 / 16:48:35 / cg"
   997 !
   998 
   999 method: aMethod
  1000     "sets aMethod"
  1001 
  1002     method := aMethod
  1003 !
  1004 
  1005 resourceType
  1006     "returns resourceType"
  1007 
  1008     resourceType isNil ifTrue: [resourceType := method resourceType].
  1009     ^resourceType
  1010 !
  1011 
  1012 selector
  1013     "returns selector"
  1014 
  1015     selector isNil ifTrue: [selector := method who methodSelector].
  1016     ^selector
  1017 ! !
  1018 
  1019 !ResourceSelectionBrowser class methodsFor:'documentation'!
  1020 
  1021 version
  1022     ^ '$Header$'
  1023 ! !