"
COPYRIGHT (c) 1997-1998 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 readResourcesProcess
mayReadResources'
classVariableNames:''
poolDictionaries:''
category:'Interface-Dialogs'
!
Object subclass:#ResourceMethod
instanceVariableNames:'method icon resourceType selector'
classVariableNames:''
poolDictionaries:''
privateIn:ResourceSelectionBrowser
!
!ResourceSelectionBrowser class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1997-1998 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 for loading or to saving resource
specifications (#canvas, #menu, etc.).
[instance variables:]
resourceMethod <Symbol> selector of the resource spec
resourceClass <Symbol> class of the resource spec
resourceSuperclass <Symbol> root class of the tree list
resourceTypes <Array> allowed resource types
allClasses <Array> list of the subclasses of resourceSuperclass
classSelectionBlock <Block> by evaluating this block the class selection is done
readResourcesProcess <Process> process of reading the resource methods
mayReadResources <Boolean> flag whether may read the resource 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
"opens a ResourceSelectionBrowser
with aTitle
on aSuperclassOrSymbol,
and aClassOrSymbol,
and aSelector,
with allowed aResourceTypes"
"
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
"returns the children for the contents (class) of aTreeItem as a block"
^[: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
"returns the default contents of the root of the class tree list"
^ Object
"Modified: / 22.4.1998 / 14:44:11 / cg"
!
treeViewIcon
"returns the icon for aTreeItem as a block"
^[:aTreeItem|
|icon|
icon := self iconClass.
aTreeItem contents isPrivate
ifTrue:
[
icon := self iconPrivateClass
].
icon
]
!
treeViewLabel
"returns the label for aTreeItem as a block"
^[: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:'@@@@@@@UUUUU!!Q****(@F**** @Z****@A****(@F**** @Z****@A****(LF**** TZ****@A****(@F**** @Z****@B@@@@@@@@@@@@@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****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]! !
!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 76 0 236 0 675 0 585 0)
#label: 'Resource Selection Browser'
#min: #(#Point 400 300)
#max: #(#Point 1152 864)
#bounds: #(#Rectangle 76 236 676 586)
#usePreferredExtent: false
)
#component:
#(#SpecCollection
#collection:
#(
#(#VariableHorizontalPanelSpec
#name: 'VariableHorizontalPanel'
#layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 0 1.0)
#component:
#(#SpecCollection
#collection:
#(
#(#ViewSpec
#name: 'Box1'
#component:
#(#SpecCollection
#collection:
#(
#(#LabelSpec
#name: 'ClassHierarchyLabel'
#layout: #(#LayoutFrame 0 0.0 2 0 0 1.0 23 0)
#label: ' Class Hierarchy:'
#level: 1
#adjust: #left
)
#(#SelectionInTreeViewSpec
#name: 'listOfClassesView'
#layout: #(#LayoutFrame 0 0.0 23 0.0 0 1.0 -60 1.0)
#tabable: true
#model: #selectionOfClass
#hasHorizontalScrollBar: true
#hasVerticalScrollBar: true
#miniScrollerHorizontal: true
#showDirectoryIndicatorForRoot: false
#showDirectoryIndicator: true
#valueChangeSelector: #classSelected
#hierarchicalList: #rootOfClasses
#validateDoubleClickSelector: #validateDoubleClick:
#contentsSelector: #treeViewContents
#labelSelector: #treeViewLabel
#childrenSelector: #treeViewChildren
#iconSelector: #treeViewIcon
)
#(#InputFieldSpec
#name: 'classNameInputField'
#layout: #(#LayoutFrame 2 0.0 -58 1 -1 1.0 -36 1)
#tabable: true
#model: #valueOfClassName
)
#(#HorizontalPanelViewSpec
#name: 'HorizontalPanelView'
#layout: #(#LayoutFrame 0 0.0 -28 1 0 1.0 -4 1)
#component:
#(#SpecCollection
#collection:
#(
#(#LabelSpec
#name: 'CreateLabel'
#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 73 24)
)
)
)
#horizontalLayout: #fit
#verticalLayout: #fit
)
)
)
)
#(#ViewSpec
#name: 'Box2'
#component:
#(#SpecCollection
#collection:
#(
#(#DataSetSpec
#name: 'resourcesDataSetView'
#layout: #(#LayoutFrame 2 0.0 2 0.0 -2 1.0 -60 1.0)
#model: #selectionOfResourceMethod
#hasHorizontalScrollBar: true
#hasVerticalScrollBar: true
#miniScrollerHorizontal: true
#rowClassName: 'ResourceSelectionBrowser::Row'
#dataList: #listOfResourceMethods
#useIndex: false
#has3Dsepartors: true
#doubleClickSelector: #resourceDoubleClicked
#columnHolder: #resourceMethodColumns
#valueChangeSelector: #resourceSelected
#verticalSpacing: 1
)
#(#InputFieldSpec
#name: 'selectorInputField'
#layout: #(#LayoutFrame 2 0.0 -58 1 -2 1.0 -36 1)
#tabable: true
#model: #valueOfResourceSelector
)
#(#HorizontalPanelViewSpec
#name: 'HorizontalPanel1'
#layout: #(#LayoutFrame 2 0.0 -28 1 -2 1.0 -4 1.0)
#component:
#(#SpecCollection
#collection:
#(
#(#ActionButtonSpec
#name: 'HelpButton'
#activeHelpKey: #dss
#label: 'Help'
#model: #openHTMLDocument:
#initiallyDisabled: true
#enableChannel: #helpEnabled
#actionValue: 'tools/uipainter/ResourceSelectionBrowser.html'
#extent: #(#Point 96 24)
)
#(#ActionButtonSpec
#name: 'cancelButton'
#activeHelpKey: #commitCancel
#label: 'Cancel'
#tabable: true
#model: #cancel
#extent: #(#Point 96 24)
)
#(#ActionButtonSpec
#name: 'okButton'
#activeHelpKey: #commitOK
#label: 'OK'
#tabable: true
#model: #accept
#isDefault: true
#extent: #(#Point 96 24)
)
)
)
#horizontalLayout: #fit
#verticalLayout: #fit
)
)
)
)
)
)
#handles: #(#Any 0.5 1.0)
)
)
)
)
! !
!ResourceSelectionBrowser class methodsFor:'list specs'!
tableColumnsForResourceMethodAttributes
"This resource specification was automatically generated
by the DataSetBuilder of ST/X."
"Do not manually edit this!! If it is corrupted,
the DataSetBuilder may not be able to read the specification."
"
DataSetBuilder new openOnClass:ResourceSelectionBrowser andSelector:#tableColumnsForResourceMethodAttributes
"
<resource: #tableColumns>
^ #(
#(#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:'aspects'!
helpEnabled
"returns whether there is a documentation file"
^true
!
listOfResourceMethods
"returns the value holder for the list of the resource methods"
|holder|
(holder := builder bindingAt:#listOfResourceMethods) isNil ifTrue:[
builder aspectAt:#listOfResourceMethods put:(holder := List new).
].
^ holder
!
resourceMethodColumns
"returns the columns for the table of the resource methods as value holder"
|holder|
(holder := builder bindingAt:#resourceMethodColumns) isNil ifTrue:[
builder aspectAt:#resourceMethodColumns put:(holder := List new).
holder addAll: (self class tableColumnsForResourceMethodAttributes collect: [:i| i decodeAsLiteralArray]).
].
^ holder
!
rootOfClasses
"returns the value holder for the root of the class tree list"
|holder|
(holder := builder bindingAt:#rootOfClasses) isNil ifTrue:[
builder aspectAt:#rootOfClasses put: (holder := TreeItem new)
].
^ holder
!
selectionOfClass
"returns the value holder for the selected class of the class tree list"
|holder|
(holder := builder bindingAt:#selectionOfClass) isNil ifTrue:[
builder aspectAt:#selectionOfClass put:(holder := ValueHolder new).
].
^ holder
!
selectionOfResourceMethod
"returns the value holder for the selected resource method of the resource method list"
|holder|
(holder := builder bindingAt:#selectionOfResourceMethod) isNil ifTrue:[
builder aspectAt:#selectionOfResourceMethod put:(holder := '' asValue).
].
^ holder
!
valueOfClassName
"returns the value holder for the name of the class"
|holder|
(holder := builder bindingAt:#valueOfClassName) isNil ifTrue:[
builder aspectAt:#valueOfClassName put:(holder := '' asValue).
].
^ holder
!
valueOfResourceSelector
"returns the value holder for the name of the selector"
|holder|
(holder := builder bindingAt:#valueOfResourceSelector) isNil ifTrue:[
builder aspectAt:#valueOfResourceSelector put:(holder := '' asValue).
].
^ holder
! !
!ResourceSelectionBrowser methodsFor:'callbacks - class list'!
treeViewContents
"returns the contents of the root of the class tree list"
|cls|
resourceSuperclass notNil ifTrue:[
cls := Smalltalk at: resourceSuperclass.
].
^ cls ? self class treeViewContents
"Modified: / 22.4.1998 / 14:43:19 / cg"
!
validateDoubleClick: aTreeItem
"returns whether a class may be selected"
^aTreeItem contents ~~ self treeViewContents
! !
!ResourceSelectionBrowser methodsFor:'callbacks - user'!
classSelected
"after a class selection, read the allowed resource methods of the selected class"
(mayReadResources not or: [self selectionOfClass value isNil]) ifTrue: [^nil].
self withWaitCursorDo:
[
|clsName|
resourceTypes isNil ifTrue: [resourceTypes := Method resourceTypes].
clsName := (self selectionOfClass value name upTo: $ ) asSymbol.
self valueOfClassName value: clsName.
self class lastSelection: clsName.
self listOfResourceMethods contents:
((((Smalltalk at: clsName)
class methodDictionary
asOrderedCollection select:
[:m| m resources notNil and: [resourceTypes includes: m resourceType]]))
collect: [:m| (ResourceMethod new method: m)]).
]
!
createClass: what
"creates a class, a subclass, or a private class of the selected class"
|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
"after a double click on resource method, accept it and close"
accept value: true.
self close
!
resourceSelected
"after a click on a resource method, set its selector into the field"
self selectionOfResourceMethod value notNil
ifTrue: [self valueOfResourceSelector value: self selectionOfResourceMethod value selector]
! !
!ResourceSelectionBrowser methodsFor:'instance creation'!
openOnSuperclass: aSuperclassOrSymbol andClass: aClassOrSymbol andSelector: aSelector withResourceTypes: aResourceTypes
"opens a ResourceSelectionBrowser on
aSuperclassOrSymbol,
and aClassOrSymbol,
and aSelector,
with allowed aResourceTypes"
|clsName|
resourceMethod := aSelector.
resourceTypes := aResourceTypes.
resourceSuperclass := aSuperclassOrSymbol isClass ifTrue: [aSuperclassOrSymbol name] ifFalse: [aSuperclassOrSymbol].
resourceClass := nil.
aClassOrSymbol isClass
ifTrue: [resourceClass := aClassOrSymbol name]
ifFalse: [
aClassOrSymbol notNil ifTrue:[
(Smalltalk at: aClassOrSymbol) notNil
ifTrue: [resourceClass := aClassOrSymbol]
]
].
self valueOfResourceSelector 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 valueOfResourceSelector value
].
^nil
"Modified: / 22.4.1998 / 14:51:03 / cg"
! !
!ResourceSelectionBrowser methodsFor:'startup / release'!
closeCancel
"after a cancel, terminate readResourcesProcess"
readResourcesProcess notNil ifTrue: [readResourcesProcess terminate].
super closeCancel
!
postBuildWith:aBuilder
"after building and before opening,
create a class selection block, an entry completion block for the class name field,
and select the class and the resource selector"
|classSelection classNameInputField|
allClasses := self treeViewContents withAllSubclasses reject: [:cls| cls isPrivate].
classSelection := resourceClass.
(classSelection isNil or:[Smalltalk at: classSelection]) isNil
ifTrue: [classSelection := self class lastSelection].
(classSelection isNil or:[Smalltalk at: classSelection]) isNil
ifTrue: [classSelection := self treeViewContents].
classSelectionBlock :=
[:clsPattern|
|foundClass classes|
clsPattern notNil ifTrue:[
foundClass := Smalltalk at:(clsPattern printString asSymbol).
].
(foundClass 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:
[
|superClasses nonSuperclasses item|
superClasses := foundClass withAllSuperclasses reverse.
(nonSuperclasses := self treeViewContents allSuperclasses) notNil
ifTrue: [superClasses := superClasses reject: [:cls| nonSuperclasses includes: cls]].
item := self rootOfClasses detectChild:[:child :arg| child contents == arg] arguments:superClasses.
item notNil ifTrue:[self selectionOfClass value:item]
].
self valueOfClassName value: clsPattern
].
self valueOfClassName value: classSelection.
(classNameInputField := builder componentAt: #classNameInputField) entryCompletionBlock:
[:value|
|what|
what := Smalltalk classnameCompletion: value withoutSpaces.
classNameInputField contents:what first.
(what at:2) size ~~ 1 ifTrue:[Screen current beep].
classSelectionBlock value: classNameInputField contents
].
mayReadResources := false.
classSelectionBlock value: classSelection.
readResourcesProcess :=
[
mayReadResources := true.
self classSelected.
self selectionOfResourceMethod value: (self listOfResourceMethods detect: [:m| m selector == resourceMethod] ifNone: nil).
readResourcesProcess := nil.
] forkAt: 4.
^super postBuildWith:aBuilder
"Modified: / 22.4.1998 / 14:48:22 / cg"
! !
!ResourceSelectionBrowser::ResourceMethod methodsFor:'accessing'!
iconOn:aGC
"registers and returns 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
"sets aMethod"
method := aMethod
!
resourceType
"returns resourceType"
resourceType isNil ifTrue: [resourceType := method resourceType].
^resourceType
!
selector
"returns selector"
selector isNil ifTrue: [selector := method who methodSelector].
^selector
! !
!ResourceSelectionBrowser class methodsFor:'documentation'!
version
^ '$Header$'
! !