ResourceSelectionBrowser.st
author tz
Mon, 30 Mar 1998 14:45:46 +0200
changeset 754 04e802a6a920
parent 746 8b3532f50ea9
child 769 bb413a70f479
permissions -rw-r--r--
color master selection in red + grid background colored

"
 COPYRIGHT (c) 1997 by eXept Software AG
              All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice. This software may not
 be provided or otherwise made available to, or used by, any
 other person. No title to or ownership of the software is
 hereby transferred.
"


SelectionBrowser subclass:#ResourceSelectionBrowser
	instanceVariableNames:'resourceMethod resourceClass resourceSuperclass resourceTypes
		allClasses classSelectionBlock classAndResourceSelectionProcess'
	classVariableNames:''
	poolDictionaries:''
	category:'Interface-Dialogs'
!

Object subclass:#Row
	instanceVariableNames:'method icon resourceType selector'
	classVariableNames:''
	poolDictionaries:''
	privateIn:ResourceSelectionBrowser
!

!ResourceSelectionBrowser class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1997 by eXept Software AG
              All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice. This software may not
 be provided or otherwise made available to, or used by, any
 other person. No title to or ownership of the software is
 hereby transferred.
"

!

documentation
"
    The ResourceSelectionBrowser allows you to browse in class hierarchies
    and to select resource methods in order to load method contents or to save
    something to methods.

    [start with:]
        ResourceSelectionBrowser open

    [author:]
        Thomas Zwick, eXept Software AG
"
! !

!ResourceSelectionBrowser class methodsFor:'instance creation'!

request: aTitle onSuperclass: aSuperclass andClass: aClass andSelector: aSelector withResourceTypes: resourceTypes

    "
    ResourceSelectionBrowser
        request: 'Select a Resource Selector'
        onSuperclass: #ApplicationModel 
        andClass: #ToolApplicationModel 
        andSelector: #saveIcon 
        withResourceTypes: #(image) 
    "

    ^self new
        title: aTitle;
        openOnSuperclass: aSuperclass
        andClass: aClass
        andSelector: aSelector
        withResourceTypes: resourceTypes
! !

!ResourceSelectionBrowser class methodsFor:'callbacks - default'!

treeViewChildren

    ^[:aTreeItem|
        |classes|
        classes := OrderedCollection new.    
        classes addAll: ((aTreeItem contents subclasses reject: [:cls| cls isPrivate]) asSortedCollection: [:i1 :i2| i1 name < i2 name]).
        classes addAll: (aTreeItem contents privateClasses asSortedCollection: [:i1 :i2| i1 name < i2 name]).
        classes
     ]
!

treeViewContents

    ^Smalltalk at: #Object




!

treeViewIcon

    ^[:aTreeItem|
        |icon|
        icon := self iconClass.
        aTreeItem contents isPrivate 
        ifTrue:
        [
           icon := self iconPrivateClass
        ].
    icon]

!

treeViewLabel

    ^[:aTreeItem|
        |label superCls|
        label := aTreeItem contents name.
        (aTreeItem contents isPrivate and: [aTreeItem parent contents ~~ (superCls := aTreeItem contents superclass)])
            ifTrue: [label := label, ' (', superCls name, ')'].
        label
     ]


! !

!ResourceSelectionBrowser class methodsFor:'image specs'!

iconClass
    "This resource specification was automatically generated
     by the ImageEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the ImageEditor may not be able to read the specification."

    "
     ImageEditor openOnClass:self andSelector:#iconClass
    "

    <resource: #image>

    ^Icon
        constantNamed:#'ResourceSelectionBrowser iconClass'
        ifAbsentPut:[(Depth2Image new) width: 18; height: 16; photometric:(#palette); bitsPerSample:(#(2 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'@@@@@@@UUUUUAQ****(@F**** @Z****@A****(@F**** @Z****@A****(LF**** TZ****@A****(@F**** @Z****@@@@@@@@@@@@@@@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]!

iconPrivateClass
    "This resource specification was automatically generated
     by the ImageEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the ImageEditor may not be able to read the specification."

    "
     ImageEditor openOnClass:self andSelector:#iconPrivateClass
    "

    <resource: #image>

    ^Icon
        constantNamed:#'ResourceSelectionBrowser iconPrivateClass'
        ifAbsentPut:[(Depth2Image new) width: 18; height: 16; photometric:(#palette); bitsPerSample:(#(2 )); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'@@@@@@PUUUUU@A****(@F*??* @Z+??*@A*/*>(OF*>+: @Z+??*@A*/?:(DF*>** @Z+:**@A*/**(@F*>** @Z****C0@@@@@@@@@@@@@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]! !

!ResourceSelectionBrowser class methodsFor:'interface specs'!

windowSpec
    "This resource specification was automatically generated
     by the UIPainter of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the UIPainter may not be able to read the specification."

    "
     UIPainter new openOnClass:ResourceSelectionBrowser andSelector:#windowSpec
     ResourceSelectionBrowser new openInterface:#windowSpec
     ResourceSelectionBrowser open
    "

    <resource: #canvas>

    ^
     
       #(#FullSpec
          #window: 
           #(#WindowSpec
              #name: 'Resource Selection Browser'
              #layout: #(#LayoutFrame 433 0 242 0 1032 0 591 0)
              #label: 'Resource Selection Browser'
              #min: #(#Point 400 300)
              #max: #(#Point 1152 864)
              #bounds: #(#Rectangle 433 242 1033 592)
              #usePreferredExtent: false
          )
          #component: 
           #(#SpecCollection
              #collection: 
               #(
                 #(#VariableHorizontalPanelSpec
                    #name: 'variableHorizontalPanel'
                    #layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 -40 1.0)
                    #component: 
                     #(#SpecCollection
                        #collection: 
                         #(
                           #(#ViewSpec
                              #name: 'view1'
                              #component: 
                               #(#SpecCollection
                                  #collection: 
                                   #(
                                     #(#SelectionInTreeViewSpec
                                        #name: 'listOfClassesView'
                                        #layout: #(#LayoutFrame 0 0.0 23 0.0 0 1.0 -22 1.0)
                                        #model: #selectionOfClass
                                        #hasHorizontalScrollBar: true
                                        #hasVerticalScrollBar: true
                                        #miniScrollerHorizontal: true
                                        #showDirectoryIndicatorForRoot: false
                                        #showDirectoryIndicator: true
                                        #valueChangeSelector: #classSelected:
                                        #hierarchicalList: #listOfClasses
                                        #contentsSelector: #treeViewContents
                                        #labelSelector: #treeViewLabel
                                        #childrenSelector: #treeViewChildren
                                        #iconSelector: #treeViewIcon
                                    )
                                     #(#InputFieldSpec
                                        #name: 'classNameInputField'
                                        #layout: #(#LayoutFrame 2 0.0 -22 1 -1 1.0 0 1)
                                        #model: #valueOfClassName
                                    )
                                     #(#LabelSpec
                                        #name: 'ClassHierarchyLabel'
                                        #layout: #(#LayoutFrame 0 0 2 0 297 0 23 0)
                                        #label: ' Class Hierarchy'
                                        #level: 1
                                        #adjust: #left
                                    )
                                  )
                              )
                          )
                           #(#ViewSpec
                              #name: 'view2'
                              #component: 
                               #(#SpecCollection
                                  #collection: 
                                   #(
                                     #(#DataSetSpec
                                        #name: 'resourcesDataSetView'
                                        #layout: #(#LayoutFrame 2 0.0 2 0.0 -2 1.0 -22 1.0)
                                        #model: #selectionOfResource
                                        #hasHorizontalScrollBar: true
                                        #hasVerticalScrollBar: true
                                        #miniScrollerHorizontal: true
                                        #rowClassName: 'ResourceSelectionBrowser::Row'
                                        #dataList: #listOfResources
                                        #useIndex: false
                                        #has3Dsepartors: true
                                        #doubleClickSelector: #resourceDoubleClicked
                                        #columnHolder: #columnsOfDataSetView
                                        #valueChangeSelector: #resourceSelected
                                        #verticalSpacing: 1
                                    )
                                     #(#InputFieldSpec
                                        #name: 'selectorInputField'
                                        #layout: #(#LayoutFrame 2 0.0 -22 1 -2 1.0 0 1)
                                        #model: #valueOfSelector
                                    )
                                  )
                              )
                          )
                        )
                    )
                    #handles: #(#Any 0.5 1.0)
                )
                 #(#UISubSpecification
                    #name: 'SubSpecification'
                    #layout: #(#LayoutFrame 301 0.0 -32 1 -2 1.0 -8 1.0)
                    #majorKey: #ToolApplicationModel
                    #minorKey: #windowSpecForCommitWithoutChannels
                )
                 #(#HorizontalPanelViewSpec
                    #name: 'HorizontalPanelView1'
                    #layout: #(#LayoutFrame 3 0 76 0.691429 300 0 0 0.977143)
                    #component: 
                     #(#SpecCollection
                        #collection: 
                         #(
                           #(#LabelSpec
                              #name: 'Label2'
                              #label: 'Create: '
                              #adjust: #right
                              #extent: #(#Point 72 24)
                          )
                           #(#ActionButtonSpec
                              #name: 'CreateClassButton'
                              #activeHelpKey: #dss
                              #label: 'Class'
                              #model: #createClass:
                              #actionValue: 'class'
                              #extent: #(#Point 72 24)
                          )
                           #(#ActionButtonSpec
                              #name: 'CreateSubclassButton'
                              #activeHelpKey: #dss
                              #label: 'Subclass'
                              #model: #createClass:
                              #actionValue: 'subclass'
                              #extent: #(#Point 72 24)
                          )
                           #(#ActionButtonSpec
                              #name: 'CreatePrivateClassButton'
                              #activeHelpKey: #dss
                              #label: 'Private'
                              #model: #createClass:
                              #actionValue: 'private'
                              #extent: #(#Point 72 24)
                          )
                        )
                    )
                    #horizontalLayout: #fit
                    #verticalLayout: #fit
                )
              )
          )
      )
! !

!ResourceSelectionBrowser class methodsFor:'list specs'!

columnsOfDataSetView

  ^ #(#(#DataSetColumnSpec
      #width: 20
      #height: 20
      #printSelector: #iconOn:
      #canSelect: false
  )
   #(#DataSetColumnSpec
      #label: ' Selector'
      #'labelAlignment:' #left
      #model: #selector
      #canSelect: false
  )
   (#DataSetColumnSpec
      #label: ' Resource Type'
      #'labelAlignment:' #left
      #model: #resourceType
      #canSelect: false
  ))
! !

!ResourceSelectionBrowser methodsFor:'accessing - views'!

classNameInputField

    ^builder componentAt: #classNameInputField
!

listOfClassesView

    ^builder componentAt: #listOfClassesView
! !

!ResourceSelectionBrowser methodsFor:'aspects'!

columnsOfDataSetView

    |holder|
    (holder := builder bindingAt:#columnsOfDataSetView) isNil ifTrue:[
        builder aspectAt:#columnsOfDataSetView put:(holder := List new).
        holder addAll: (self class columnsOfDataSetView collect: [:i| i decodeAsLiteralArray]).
    ].
    ^ holder


!

listOfClasses

    |holder|
    (holder := builder bindingAt:#listOfClasses) isNil ifTrue:[
        builder aspectAt:#listOfClasses put: (holder := TreeItem new)
    ].
    ^ holder


!

listOfResources

    |holder|
    (holder := builder bindingAt:#listOfResources) isNil ifTrue:[
        builder aspectAt:#listOfResources put:(holder :=  List new).
    ].
    ^ holder
!

selectionOfClass

    |holder|
    (holder := builder bindingAt:#selectionOfClass) isNil ifTrue:[
        builder aspectAt:#selectionOfClass put:(holder :=  ValueHolder new).
    ].
    ^ holder
!

selectionOfResource

    |holder|
    (holder := builder bindingAt:#selectionOfResource) isNil ifTrue:[
        builder aspectAt:#selectionOfResource put:(holder :=  '' asValue).
    ].
    ^ holder
!

valueOfClassName

    |holder|
    (holder := builder bindingAt:#valueOfClassName) isNil ifTrue:[
        builder aspectAt:#valueOfClassName put:(holder :=  '' asValue).
    ].
    ^ holder
!

valueOfSelector

    |holder|
    (holder := builder bindingAt:#valueOfSelector) isNil ifTrue:[
        builder aspectAt:#valueOfSelector put:(holder :=  '' asValue).
    ].
    ^ holder
! !

!ResourceSelectionBrowser methodsFor:'callbacks - tree view'!

treeViewContents

    ^(Smalltalk at: resourceSuperclass) ? self class treeViewContents


! !

!ResourceSelectionBrowser methodsFor:'callbacks - user'!

classSelected: anIndex

    self selectionOfClass value isNil ifTrue: [^nil].
    self withWaitCursorDo:
    [
        |clsName|
        resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes].
        clsName := ((self listOfClassesView list at: anIndex) upTo: $ ) asSymbol.
        self valueOfClassName value: clsName.
        self class lastSelection: clsName.
        self listOfResources contents:
            ((((Smalltalk at: clsName) 
                class methodDictionary
                asOrderedCollection select: 
                    [:m| m resources notNil and: [resourceTypes includes: m resourceType]]))
             collect: [:m| Row new method: m]).
    ]
!

createClass: what

    |clsCandidat cls|
    clsCandidat := self valueOfClassName value asSymbol.

    (Smalltalk at: clsCandidat) notNil 
        ifTrue: [^self warn: 'Cannot create class ', clsCandidat asBoldText,
                '!!\Key with that name in dictionary ' withCRs, 'Smalltalk' asBoldText, ' detected.'].

    cls := self selectionOfClass value contents.
    what = 'class' ifTrue: [cls := cls superclass].

    cls isNil ifTrue: [^self warn: 'May not create class with superclass ', 'nil' asBoldText, '!!'].

    what = 'private' 
    ifFalse: 
    [
        cls subclass: clsCandidat
            instanceVariableNames:''
            classVariableNames:''
            poolDictionaries:''
            category: cls category
    ]
    ifTrue:
    [
        |superClsCandidate|
        superClsCandidate := (Dialog 
                request: 'Enter name of superclass of private class.'
                initialAnswer: 'Object') asSymbol.
        (Smalltalk at: superClsCandidate) isNil ifTrue: [^self warn: 'Class ', superClsCandidate asBoldText, ' does not exist!!'].

        ((superClsCandidate := Smalltalk at: superClsCandidate) isClass and: [superClsCandidate isPrivate not])
            ifFalse: [^self warn: 'May not create private class with superclass ', superClsCandidate asBoldText, '!!'].
        superClsCandidate subclass: clsCandidat
            instanceVariableNames:''
            classVariableNames:''
            poolDictionaries:''
            privateIn: cls
    ].

    allClasses := Object withAllSubclasses.

    what = 'class' 
        ifTrue:  [self selectionOfClass value parent changed: #children]
        ifFalse: [self selectionOfClass value changed: #children].

    classSelectionBlock value: self valueOfClassName value 
!

resourceDoubleClicked

    resourceMethod := self selectionOfResource value.
    accept value: true.
    self close
!

resourceSelected

    resourceMethod := self selectionOfResource value.
    self selectionOfResource value notNil
        ifTrue: [self valueOfSelector value: self selectionOfResource value selector]
! !

!ResourceSelectionBrowser methodsFor:'instance creation'!

openOnSuperclass: aSuperclassOrSymbol andClass: aClassOrSymbol andSelector: aSelector withResourceTypes: aResourceTypes

    |clsName|
    resourceMethod := aSelector.
    resourceTypes := aResourceTypes.
    resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol].
    resourceClass := aClassOrSymbol isClass 
        ifTrue: [aClassOrSymbol name] 
        ifFalse: [(Smalltalk at: aClassOrSymbol) notNil
            ifTrue: [aClassOrSymbol]
            ifFalse: [nil]].      
    self valueOfSelector value:(aSelector ? '').

    self open.

    (clsName := self selectionOfClass value) isNil ifTrue: [^nil].
    clsName := (clsName name upTo: $ ) asSymbol.

    ((Smalltalk at: clsName) isClass and: [accept value]) 
    ifTrue:
    [            
        ^clsName, ' ', self valueOfSelector value
    ].
    ^nil
! !

!ResourceSelectionBrowser methodsFor:'startup / release'!

closeCancel

    resourceMethod := nil.
    classAndResourceSelectionProcess notNil ifTrue: [classAndResourceSelectionProcess terminate].
    super closeCancel



!

postBuildWith:aBuilder

    |classSelection|
    allClasses := Object withAllSubclasses.
    classSelection :=  resourceClass. 
    (Smalltalk at: classSelection) isNil 
        ifTrue: [classSelection :=  self class lastSelection].
    (Smalltalk at: classSelection) isNil 
        ifTrue: [classSelection :=  #Object].
    classSelectionBlock := 
    [:clsPattern|                                  
        |foundClass classes|         
        ((foundClass := Smalltalk at: clsPattern printString asSymbol) isClass not or:
        [foundClass name ~= clsPattern])
        ifTrue:
        [
            classes := allClasses select: [:cls| cls name size >= clsPattern size].
            1 to: clsPattern size do: 
            [:i|    
                 classes := classes select: [:cls| (cls name at: i) == (clsPattern at: i)].
            ].    
            foundClass := classes at: 1 ifAbsent: [nil] 
        ].
        foundClass notNil
        ifTrue:
        [
            self listOfClassesView 
                selectFromListOfNames: (foundClass 
                    withAllSuperclasses reverse collect: [:cls| cls name asString]);
                selectedNodeExpand: true
        ].
        self valueOfClassName value: clsPattern
    ].
    self valueOfClassName value: classSelection.  
    self classNameInputField entryCompletionBlock:
    [:value|
        |what|
        what := Smalltalk classnameCompletion: value withoutSpaces.
        self classNameInputField contents:what first.
        (what at:2) size ~~ 1 ifTrue:[Display beep].
        classSelectionBlock value: self classNameInputField contents
    ].
    self listOfClassesView validateDoubleClickBlock: [:aTreeItem | aTreeItem contents ~~ self treeViewContents].
    self listOfClassesView selectedNodeExpand: true.

    classAndResourceSelectionProcess := 
    [
        [classSelectionBlock value: classSelection] value.
        self selectionOfResource value: (self listOfResources detect: [:m| m selector == resourceMethod] ifNone: nil).
        classAndResourceSelectionProcess := nil
    ]
    forkAt: 4.

    ^super postBuildWith:aBuilder

! !

!ResourceSelectionBrowser::Row methodsFor:'accessing'!

iconOn:aGC
    "register and answer an icon indicating the resource type."

    self resourceType isNil ifTrue: [^nil].
    icon isNil 
    ifTrue: 
    [
        |cls sel image imageKey|
        ((self resourceType = #image) or: [resourceType = #fileImage])
        ifTrue: 
        [  
            cls := method who methodClass soleInstance.
            sel := method who methodSelector.
        ]
        ifFalse:
        [
            cls := BrowserView.
            sel := (resourceType, 'Icon') asSymbol.
        ].
        imageKey := (cls name, sel) asSymbol.
        (icon := aGC registeredImageAt: imageKey) isNil
        ifTrue:
        [       
            image := cls perform: sel.
            image extent y > 18
            ifTrue:
            [         
                image := image magnifiedBy: 18/image extent y
            ].
            aGC registerImage: image key: imageKey.
            icon := aGC registeredImageAt: imageKey.
        ].
    ].
    ^icon
!

method: aMethod

    method := aMethod
!

resourceType

    resourceType isNil ifTrue: [resourceType := method resourceType].
    ^resourceType
!

selector

    selector isNil ifTrue: [selector := method who methodSelector].
    ^selector
! !

!ResourceSelectionBrowser class methodsFor:'documentation'!

version
    ^ '$Header$'
! !