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