ResourceSelectionBrowser.st
author Patrik Svestka <patrik.svestka@gmail.com>
Wed, 14 Nov 2018 12:07:51 +0100
branchjv
changeset 3630 5e718e0a754e
parent 3198 d0f01dc022bb
child 3528 f697558c47cd
permissions -rw-r--r--
Issue #239: Fix all Smalltak/X source files to be in unicode (UTF8 without BOM) and prefixed by "{ Encoding: utf8 }" when any unicode character is present

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