"
COPYRIGHT (c) 2004 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.
"
"{ Package: 'stx:libtool' }"
"{ NameSpace: Tools }"
BrowserList subclass:#ClassList
instanceVariableNames:'classList classNameList meta lastSelectedClasses
selectedClassNameIndices currentNamespace hidePrivateClasses
unloadedClassesColor markApplicationsHolder classFilterBlock
showCoverageInformationHolder'
classVariableNames:''
poolDictionaries:''
category:'Interface-Browsers-New'
!
!ClassList class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2004 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
"
embeddable application displaying the classes as listed by
the inputGenerator.
Provides an outputGenerator, which enumerates the classes and
their protocols (method-categories) in the selected classes.
[author:]
Claus Gittinger (cg@exept.de)
"
! !
!ClassList class methodsFor:'interface specs'!
singleClassWindowSpec
"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:ClassList andSelector:#singleClassWindowSpec
ClassList new openInterface:#singleClassWindowSpec
"
<resource: #canvas>
^
#(#FullSpec
#name: #windowSpec
#window:
#(#WindowSpec
#label: 'ClassList'
#name: 'ClassList'
#min: #(#Point 0 0)
#max: #(#Point 1024 721)
#bounds: #(#Rectangle 12 22 312 322)
)
#component:
#(#SpecCollection
#collection: #(
#(#LabelSpec
#label: 'ClassName'
#name: 'ClassLabel'
#layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0)
#translateLabel: true
#labelChannel: #classLabelHolder
#menu: #menuHolder
)
"/ #(#UISubSpecification
"/ #name: 'MetaToggleSpec'
"/ #layout: #(#LayoutFrame 0 0.0 -25 1.0 0 1.0 0 1.0)
"/ #minorKey: #metaSpec
"/ )
)
)
)
!
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:ClassList andSelector:#windowSpec
ClassList new openInterface:#windowSpec
ClassList open
"
<resource: #canvas>
^
#(#FullSpec
#name: #windowSpec
#window:
#(#WindowSpec
#label: 'ClassList'
#name: 'ClassList'
#min: #(#Point 0 0)
#max: #(#Point 1024 721)
#bounds: #(#Rectangle 16 46 316 346)
)
#component:
#(#SpecCollection
#collection: #(
#(#SequenceViewSpec
#name: 'List'
#layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 0 1.0)
#tabable: true
#model: #selectedClassNameIndices
#menu: #menuHolder
#hasHorizontalScrollBar: true
#hasVerticalScrollBar: true
#miniScrollerHorizontal: true
#isMultiSelect: true
#valueChangeSelector: #selectionChangedByClick
#useIndex: true
#sequenceList: #classNameList
#doubleClickChannel: #doubleClickChannel
#properties:
#(#PropertyListDictionary
#dragArgument: nil
#dropArgument: nil
#canDropSelector: #canDropContext:
#dropSelector: #doDropContext:
)
)
)
)
)
! !
!ClassList class methodsFor:'plugIn spec'!
aspectSelectors
"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."
"Return a description of exported aspects;
these can be connected to aspects of an embedding application
(if this app is embedded in a subCanvas)."
^ #(
#currentNamespace
#(#doubleClickChannel #action )
#forceGeneratorTrigger
#hidePrivateClasses
#hideUnloadedClasses
#immediateUpdate
#inGeneratorHolder
#menuHolder
#meta
#organizerMode
#outGeneratorHolder
#packageFilter
#nameSpaceFilter
#selectedClasses
#selectionChangeCondition
#showClassPackages
#slaveMode
#updateTrigger
#markApplicationsHolder
#showCoverageInformationHolder
).
"Modified: / 27-04-2010 / 15:45:02 / cg"
! !
!ClassList methodsFor:'accessing'!
markApplications
"return the value of the instance variable 'markApplications' (automatically generated)"
^ self markApplicationsHolder value
"Created: / 3.11.2001 / 14:06:19 / cg"
!
markApplications:something
"set the value of the instance variable 'markApplications' (automatically generated)"
self markApplicationsHolder value:something.
"Created: / 3.11.2001 / 14:06:25 / cg"
!
unloadedClassesColor
"return the value of the instance variable 'unloadedClassesColor' (automatically generated)"
^ unloadedClassesColor
!
unloadedClassesColor:something
"set the value of the instance variable 'unloadedClassesColor' (automatically generated)"
unloadedClassesColor := something.
! !
!ClassList methodsFor:'aspects'!
classLabelHolder
^ self pseudoListLabelHolder
!
classList
classList isNil ifTrue:[
classList := ValueHolder new.
].
^ classList
"Created: / 5.2.2000 / 13:42:16 / cg"
"Modified: / 25.2.2000 / 02:21:07 / cg"
!
classNameList
classNameList isNil ifTrue:[
classNameList := ValueHolder new
].
^ classNameList
!
currentNamespace:aValueHolder
currentNamespace notNil ifTrue:[
currentNamespace removeDependent:self
].
currentNamespace := aValueHolder.
currentNamespace notNil ifTrue:[
currentNamespace isBehavior ifTrue:[self halt:'should not happen'].
currentNamespace addDependent:self
].
"Modified: / 4.2.2000 / 23:34:28 / cg"
"Created: / 5.2.2000 / 21:37:57 / cg"
!
doubleClick
self halt:'should not happen'.
!
hidePrivateClasses
hidePrivateClasses isNil ifTrue:[
hidePrivateClasses := false asValue.
hidePrivateClasses addDependent:self.
].
^ hidePrivateClasses.
"Created: / 24.2.2000 / 15:06:44 / cg"
!
hidePrivateClasses:aValueHolder
hidePrivateClasses notNil ifTrue:[
hidePrivateClasses removeDependent:self
].
hidePrivateClasses := aValueHolder.
hidePrivateClasses notNil ifTrue:[
hidePrivateClasses addDependent:self
].
"Created: / 24.2.2000 / 15:06:46 / cg"
!
markApplicationsHolder
markApplicationsHolder isNil ifTrue:[
markApplicationsHolder := true asValue.
markApplicationsHolder addDependent:self.
].
^ markApplicationsHolder.
!
markApplicationsHolder:aValueHolder
markApplicationsHolder notNil ifTrue:[
markApplicationsHolder removeDependent:self
].
markApplicationsHolder := aValueHolder.
markApplicationsHolder notNil ifTrue:[
markApplicationsHolder addDependent:self
].
"Created: / 24.2.2000 / 15:06:46 / cg"
!
meta
meta isNil ifTrue:[
meta := false asValue.
meta addDependent:self
].
^ meta
"Modified: / 31.1.2000 / 01:19:59 / cg"
"Created: / 5.2.2000 / 13:42:16 / cg"
!
meta:aValueHolder
"/ (aValueHolder == true or:[aValueHolder == false]) ifTrue:[self halt].
meta notNil ifTrue:[
meta removeDependent:self
].
meta := aValueHolder.
meta notNil ifTrue:[
meta addDependent:self
].
!
selectClass:aClass
self selectedClasses value:(Array with:aClass)
!
selectedClassNameIndices
selectedClassNameIndices isNil ifTrue:[
selectedClassNameIndices := #() asValue.
selectedClassNameIndices addDependent:self
].
^ selectedClassNameIndices.
"Created: / 5.2.2000 / 21:31:48 / cg"
"Modified: / 5.2.2000 / 21:43:02 / cg"
!
selectedClasses
"bad name- its a holder, baby"
^ self selectionHolder
!
selectedClasses:aValueHolder
"bad name- its a holder, baby"
^ self selectionHolder:aValueHolder
!
showClassPackages
showClassPackages isNil ifTrue:[
showClassPackages := false asValue.
showClassPackages addDependent:self.
].
^ showClassPackages.
"Created: / 24.2.2000 / 15:06:44 / cg"
!
showClassPackages:aValueHolder
showClassPackages notNil ifTrue:[
showClassPackages removeDependent:self
].
showClassPackages := aValueHolder.
showClassPackages notNil ifTrue:[
showClassPackages addDependent:self
].
!
showCoverageInformationHolder
showCoverageInformationHolder isNil ifTrue:[
showCoverageInformationHolder := false asValue.
showCoverageInformationHolder addDependent:self.
].
^ showCoverageInformationHolder.
"Created: / 27-04-2010 / 15:44:06 / cg"
!
showCoverageInformationHolder:aValueHolder
showCoverageInformationHolder notNil ifTrue:[
showCoverageInformationHolder removeDependent:self
].
showCoverageInformationHolder := aValueHolder.
showCoverageInformationHolder notNil ifTrue:[
showCoverageInformationHolder addDependent:self
].
"Created: / 27-04-2010 / 15:44:49 / cg"
! !
!ClassList methodsFor:'change & update'!
classDefinitionChanged:aClassOrNil
listValid ifFalse:[^ self].
slaveMode value == true ifTrue:[
self invalidateList.
^ self.
].
self slaveMode value isNil ifTrue:[
self window shown ifFalse:[
self invalidateList.
^ self
].
].
aClassOrNil isNil ifTrue:[
self halt:'should not happen'.
].
"/ if that class is in my list ...
((self classList value ? #()) contains:[:cls | cls notNil and:[cls theNonMetaclass name = aClassOrNil theNonMetaclass name]])
ifTrue:[
self updateListsFor:aClassOrNil.
"/ force update
self selectedClassNameIndices value:(self selectedClassNameIndices value).
((self selectedClasses value ? #()) contains:[:cls | cls notNil ifTrue:[cls theNonMetaclass name = aClassOrNil theNonMetaclass name] ifFalse:[false]])
ifTrue:[
self updateOutputGenerator
].
] ifFalse:[
self invalidateList
]
"Modified: / 29.2.2000 / 00:15:23 / cg"
!
classRemoved:aClass
|list|
list := self classList value.
list notNil ifTrue:[
(list includesIdentical:aClass) ifTrue:[
self invalidateList.
]
]
"Modified: / 25.2.2000 / 23:53:51 / cg"
!
delayedUpdate:something with:aParameter from:changedObject
|cls classes chgClass wg savedList|
classes := self classList value ? #().
self inSlaveModeOrInvisible ifTrue:[
self invalidateList.
^ self.
].
"/ (self slaveMode value == true) ifTrue:[^ self].
"/ self slaveMode value isNil ifTrue:[
"/ self window shown ifFalse:[
"/ self invalidateList.
"/ ^ self
"/ ].
"/ ].
changedObject == slaveMode ifTrue:[
listValid ~~ true ifTrue:[
self enqueueDelayedUpdateList.
].
self enqueueDelayedClassSelectionChanged.
^ self
].
changedObject == Smalltalk ifTrue:[
something == #methodInClass ifTrue:[
^ self "no interest"
].
something == #methodInClassRemoved ifTrue:[
"/ must update the list, if the methods package is different from
"/ the classes package (to undo any has-exension highlighting)
cls := aParameter first.
self updateListsFor:cls.
^ self
].
something == #organization ifTrue:[^ self "no interest" ].
(something == #classDefinition
or:[something == #classVariables
or:[something == #newClass]]) ifTrue:[
"/ update that class in my classList and the selection
listValid ifTrue:[
self classDefinitionChanged:aParameter.
].
^ self.
].
(something == #lastTestRunResult) ifTrue:[
"/ update that class in my classList and the selection
listValid ifTrue:[
self updateListsFor:aParameter.
"/ self classDefinitionChanged:aParameter.
].
^ self.
].
something == #classRemove ifTrue:[
"/ update my classList and the selection
self classRemoved:aParameter.
^ self.
].
something == #classRename ifTrue:[
"/ update that class in my classList and the selection
listValid ifTrue:[
aParameter isArray ifTrue:[
cls := aParameter at:1.
self classDefinitionChanged:cls.
]
].
^ self.
].
something == #projectOrganization ifTrue:[
aParameter isNil ifTrue:[
self invalidateList.
organizerMode value == #project ifTrue:[
self enqueueDelayedUpdateOutputGenerator.
].
^ self
].
cls := aParameter at:1.
cls notNil ifTrue:[ "/ should not happen (but does occasionally)
((classes includes:cls theMetaclass)
or:[(classes includes:cls theNonMetaclass)]) ifTrue:[
self invalidateList.
organizerMode value == #project ifTrue:[
self enqueueDelayedUpdateOutputGenerator.
]
].
].
^ self
].
^ self.
].
(something == #lastTestRunResult) ifTrue:[
^ self
].
changedObject == ChangeSet ifTrue:[
wg := self windowGroup.
wg isNil ifTrue:[
changedObject removeDependent:self.
] ifFalse:[
"/ react on changes of the changeSet to recolorize items
something == #addChange: ifTrue:[
chgClass := aParameter changeClass.
chgClass notNil ifTrue:[
((classes includes:chgClass theNonMetaclass)
or:[classes includes:chgClass theMetaclass]) ifTrue:[
"/ remove all other addChange notifications ...
wg sensor
flushEventsFor:self
where:[:ev | ev isMessageSendEvent
and:[ev selector == #delayedUpdate:with:from:
and:[(ev arguments at:3) == ChangeSet]]].
self reconstructNameList.
]
]
] ifFalse:[
"/ remove all other ChangeSet notifications ...
wg sensor
flushEventsFor:self
where:[:ev | ev isMessageSendEvent
and:[ev selector == #delayedUpdate:with:from:
and:[(ev arguments at:3) == ChangeSet]]].
self reconstructNameList.
].
].
^ self
].
changedObject == self selectedClasses ifTrue:[
slaveMode value ~~ true ifTrue:[
savedList := self selectedClasses value.
lastSelectedClasses := nil.
listValid == true ifFalse:[
self updateList
].
self selectedClasses setValue:savedList.
self selectedClassesChanged.
self updateOutputGenerator.
] ifFalse:[
listValid := false.
].
^ self
].
(changedObject == meta
or:[changedObject == selectedClassNameIndices]) ifTrue:[
self selectionChanged.
^ self
].
changedObject == showClassPackages ifTrue:[
self classNameList value:nil.
self invalidateList.
^ self
].
(changedObject == hideUnloadedClasses
or:[changedObject == hidePrivateClasses
or:[changedObject == nameSpaceFilter
or:[changedObject == packageFilter]]]) ifTrue:[
self invalidateList.
^ self
].
super delayedUpdate:something with:aParameter from:changedObject
"Modified: / 13.11.2001 / 11:32:10 / cg"
!
enqueueDelayedClassSelectionChanged
(NewSystemBrowser synchronousUpdate == true
or:[ immediateUpdate value == true ])
ifTrue:[
self selectedClassesChanged.
^ self.
].
self enqueueMessage:#selectedClassesChanged for:self arguments:#()
!
getSelectedClassIndicesFromClasses
"the class selection has changed;
return a collection of selection-indices"
|classes selectedClasses numSelected|
classes := self classList value.
selectedClasses := self selectedClasses value.
numSelected := selectedClasses size.
numSelected == 0 ifTrue:[
^ #()
].
numSelected == classes size ifTrue:[
"/ all selected - easy
^ (1 to:numSelected) asOrderedCollection
].
meta value ifTrue:[
classes := classes collect:[:eachClass | eachClass theMetaclass].
].
classes := selectedClasses collect:[:aSelectedClass | classes identityIndexOf:aSelectedClass.].
classes := classes select:[:idx | idx ~= 0].
^ classes
"Created: / 24.2.2000 / 19:47:52 / cg"
!
getSelectedClassesFromIndices
"the selection-index collection has changed;
return a collection of corresponding classes"
|selected classes allEntrySelected isMeta anyLost selectedClassNameIndices|
allEntrySelected := false.
classes := classList value.
classes isNil ifTrue:[
self updateList.
classes := classList value.
].
isMeta := meta value.
anyLost := false.
selectedClassNameIndices := self selectedClassNameIndices value.
selectedClassNameIndices size == classes size ifTrue:[
selectedClassNameIndices size == 0 ifTrue:[^ #()].
isMeta ifTrue:[
^ classes collect:[:eachClass | eachClass theMetaclass].
].
^ classes collect:[:eachClass | eachClass theNonMetaclass].
].
selected := selectedClassNameIndices
collect:[:idx |
|cls|
cls := classes at:idx.
cls == (self class nameListEntryForALL) ifTrue:[
allEntrySelected := true.
] ifFalse:[
cls notNil ifTrue:[
isMeta ifTrue:[
cls := cls theMetaclass
] ifFalse:[
cls := cls theNonMetaclass
].
] ifFalse:[
anyLost := true
].
].
cls
].
anyLost ifTrue:[
selected := selected select:[:each | each notNil].
].
"/ allEntrySelected ifTrue:[
"/ selected := classList value select:[:cls | cls ~~ AllEntry].
"/ meta value ifTrue:[
"/ selected := selected collect:[:cls | cls theMetaclass].
"/ ] ifFalse:[
"/ selected := selected collect:[:cls | cls theNonMetaclass].
"/ ].
"/ ].
^ selected.
"Created: / 24.2.2000 / 19:43:37 / cg"
!
selectedClassesChanged
|indices selectedClassNameIndicesHolder|
self classList value size == 0 ifTrue:[
"/ this may happen during early startup,
"/ when invoked with a preset classSelection,
"/ and the classGenerator has not yet been setup
"/ to not clobber the selection, defer the update
"/ until the classList arrives ...
^ self
].
"/ lastSelectedClasses := self selectedClasses value copy.
indices := self getSelectedClassIndicesFromClasses.
selectedClassNameIndicesHolder := self selectedClassNameIndices.
selectedClassNameIndicesHolder value ~= indices ifTrue:[
"/ in slaveMode, do not update selectedClasses from indices
true "slaveMode value" ifTrue:[
selectedClassNameIndicesHolder value:indices withoutNotifying:self
] ifFalse:[
selectedClassNameIndicesHolder value:indices.
]
]
"Created: / 13.2.2000 / 22:18:10 / cg"
"Modified: / 24.2.2000 / 19:48:56 / cg"
!
selectionChanged
"the lists selection has changed. Since the list uses indices,
update the corresponding selectedClasses collection"
|selected prevSelection selectedClassesHolder|
selectedClassesHolder := self selectedClasses.
selected := self getSelectedClassesFromIndices.
prevSelection := selectedClassesHolder value ? #().
prevSelection ~= selected ifTrue:[
selectedClassesHolder value:selected.
].
!
selectionChangedByClick
"we are not interested in that - get another notification
via the changed valueHolder"
|selected master|
selected := self getSelectedClassesFromIndices.
(selected = lastSelectedClasses and:[selected size == 1])
ifTrue:[
"/ thats a kludge - we want to turn off the protocol selection,
"/ when a class is reselected.
masterApplication notNil ifTrue:[
master := masterApplication.
masterApplication masterApplication notNil ifTrue:[
master := masterApplication masterApplication.
].
(master respondsTo:#classReselected) ifTrue:[
master classReselected.
].
]
] ifFalse:[
lastSelectedClasses := selected copy.
]
!
update:something with:aParameter from:changedObject
|cls sel newMethod oldMethod idx classListValue|
self slaveMode value == true ifTrue:[
something == #methodInClass ifTrue:[ ^ self ].
something == #addChange: ifTrue:[ self invalidateList. ^ self ].
].
"/ self window sensor isNil ifTrue:[
"/ "/ not visible ...
"/ self invalidateList.
"/ ^ self
"/ ].
classListValue := classList value.
changedObject == Smalltalk ifTrue:[
something == #classComment ifTrue:[
^ self.
].
something == #methodDictionary ifTrue:[
^ self
].
something == #methodTrap ifTrue:[
^ self
].
something == #lastTestRunResult ifTrue:[
cls := aParameter at:1.
sel := aParameter at:2.
(cls notNil and:[sel isNil]) ifTrue:[
classListValue size > 0 ifTrue:[
((classListValue includesIdentical:cls theNonMetaclass)
or:[(classListValue includesIdentical:cls theMetaclass)]) ifTrue:[
self enqueueDelayedUpdateList
]
]
].
^ self
].
something == #methodInClassRemoved ifTrue:[
cls := aParameter at:1.
cls notNil ifTrue:[
classListValue size > 0 ifTrue:[
((classListValue includesIdentical:cls theNonMetaclass)
or:[(classListValue includesIdentical:cls theMetaclass)]) ifTrue:[
self enqueueDelayedUpdateList
]
]
].
^ self
].
something == #methodInClass ifTrue:[
cls := aParameter at:1.
cls notNil ifTrue:[
classListValue size > 0 ifTrue:[
((classListValue includesIdentical:cls theNonMetaclass)
or:[(classListValue includesIdentical:cls theMetaclass)]) ifTrue:[
newMethod := cls compiledMethodAt:(aParameter at:2).
oldMethod := aParameter at:3.
((oldMethod isNil
and:[newMethod package ~= cls package])
or:[oldMethod notNil
and:[newMethod package ~= oldMethod package]])
ifTrue:[
"/ must update the list (for the package-info)
self enqueueDelayedUpdateList
]
]
]
].
^ self
].
"/ kludge: must be careful if my inGenerator is a constant list.
"/ in that case, I have to update it
"/ (sigh - all a consequence of not #becoming the new class)
((something == #classDefinition) or:[something == #newClass]) ifTrue:[
inGeneratorHolder value isOrderedCollection ifTrue:[
idx := inGeneratorHolder value findFirst:[:eachClass | eachClass name = aParameter theNonMetaclass name].
idx ~~ 0 ifTrue:[
inGeneratorHolder value at:idx put:aParameter.
self updateListsFor:aParameter.
"/ self enqueueDelayedUpdateList.
]
] ifFalse:[
classListValue size > 0 ifTrue:[
idx := classListValue findFirst:[:eachClass | eachClass name = aParameter theNonMetaclass name].
idx ~~ 0 ifTrue:[
listValid ifTrue:[
self classDefinitionChanged:aParameter.
^ self.
]
]
].
].
].
].
super update:something with:aParameter from:changedObject
"Modified: / 06-08-2006 / 11:13:59 / cg"
! !
!ClassList methodsFor:'drag & drop'!
canDropContext:aDropContext
|objects|
objects := aDropContext dropObjects collect:[:obj | obj theObject].
(objects conform:[:anObject | anObject isMethod]) ifTrue:[
|methods cls|
methods := objects.
cls := self classAtTargetPointOf:aDropContext.
cls isNil ifTrue:[^ false].
^ methods contains:[:aMethod | aMethod mclass ~= cls]
].
(self objectsAreClassFiles:objects) ifTrue:[^ true].
^ false.
"Modified: / 17-10-2006 / 18:26:07 / cg"
!
classAtTargetPointOf:aDropContext
|p classListView lineNr cls|
p := aDropContext targetPoint.
classListView := aDropContext targetWidget.
lineNr := classListView lineAtY:p y.
lineNr isNil ifTrue:[^ nil].
cls := classList value at:lineNr.
^ cls
!
doDropContext:aDropContext
|objects browser|
browser := self masterApplication.
objects := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
(objects conform:[:something | something isMethod]) ifTrue:[
|cls methods|
methods := objects.
cls := self classAtTargetPointOf:aDropContext.
methods first mclass isMeta ifTrue:[
cls := cls theMetaclass
].
cls notNil ifTrue:[
methods := methods reject:[:mthd | mthd mclass theNonMetaclass == cls theNonMetaclass].
methods notEmpty ifTrue:[
aDropContext dragType == DropContext dragTypeCopy ifTrue:[
browser copyMethods:methods toClass:cls.
] ifFalse:[
browser moveMethods:methods toClass:cls.
].
]
].
^ self
].
(objects conform:[:something | something isFilename]) ifTrue:[
self dropClassFiles:objects.
^ self
].
"Modified: / 21-10-2006 / 20:39:55 / cg"
! !
!ClassList methodsFor:'generators'!
makeGenerator
"return a generator which enumerates the method categories from the selected class;
that generator generates 2-element elements (includes the class), in order
to make the consumers only depend on one input (i.e. no need for another
classHolder in the methodList)."
^ Iterator
on:[:whatToDo |
|allEntry classes cls already anyMethod packages classIsInPackage showChanged|
allEntry := self class nameListEntryForALL.
classes := self selectedClasses value ? #().
packages := packageFilter value value.
(packages notNil and:[packages includes:allEntry]) ifTrue:[packages := nil].
showChanged := packages notNil and:[packages includes:NavigatorModel nameListEntryForChanged].
classes do:[:cls |
(cls notNil and:[cls ~~ allEntry]) ifTrue:[
anyMethod := false.
classIsInPackage := packages isNil
or:[(packages includes:cls package)
or:[ showChanged and:[ChangeSet current changedClasses includes:cls]] ].
cls theNonMetaclass isJavaClass ifTrue:[
cls isMeta ifTrue:[
whatToDo value:cls theNonMetaclass value:(self class nameListEntryForStatic).
] ifFalse:[
whatToDo value:cls value:(self class nameListEntryForNonStatic).
]
] ifFalse:[
cls supportsMethodCategories ifTrue:[
already := Set new.
cls methodDictionary keysAndValuesDo:[:sel :mthd |
|cat|
cat := mthd category.
(already includes:cat) ifFalse:[
(classIsInPackage
or:[packages isNil
or:[packages includes:mthd package]])
ifTrue:[
already add:cat.
whatToDo value:cls value:cat.
]
]
].
] ifFalse:[
whatToDo value:cls value:(self class nameListEntryForNILCategory).
].
].
anyMethod ifFalse:[
"/ tell the one below, which classes are seen here,
"/ (even if no method is present)
"/ to allow him to decide if the className is to be shown in the list
whatToDo value:cls value:nil.
].
].
].
]
"Modified: / 24.2.2000 / 23:18:26 / cg"
! !
!ClassList methodsFor:'private'!
listOfClasses
|classesAlready classesOrdered generator nameSpaceFilter packageFilter allName hidePrivate
privateClassesPerClass|
allName := self class nameListEntryForALL.
(self showAllClassesInNameSpaceOrganisation value) ifFalse:[
nameSpaceFilter := self nameSpaceFilter value.
nameSpaceFilter notNil ifTrue:[
(nameSpaceFilter includes:allName) ifTrue:[
nameSpaceFilter := nil
].
].
].
"/ packageFilter := self packageFilter value.
"/ packageFilter notNil ifTrue:[
"/ (packageFilter includes:allName) ifTrue:[packageFilter := nil].
"/ ].
inGeneratorHolder isNil ifTrue:[
"/ for standAlone testing
generator := Smalltalk allClasses.
(self hideUnloadedClasses value) ifTrue:[
generator := generator select:[:cls | cls isLoaded]
].
] ifFalse:[
generator := inGeneratorHolder value.
generator isNil ifTrue:[^ #() ].
].
classesAlready := IdentitySet new.
classesOrdered := OrderedCollection new.
hidePrivate := self hidePrivateClasses value.
privateClassesPerClass := IdentityDictionary new.
generator do:[:cls |
|owner bucket|
(hidePrivate not or:[cls isPrivate not])
ifTrue:[
(nameSpaceFilter isNil
or:[self isClass:cls shownWithNameSpaceFilter:nameSpaceFilter]) ifTrue:[
(packageFilter isNil
or:[self isClass:cls shownWithPackageFilter:packageFilter]) ifTrue:[
(classesAlready includes:cls) ifFalse:[
(classFilterBlock isNil
or:[(classFilterBlock value:cls)]) ifTrue:[
classesAlready add:cls.
(owner := cls owningClass) notNil ifTrue:[
bucket := privateClassesPerClass
at:owner
ifAbsentPut:[SortedCollection new
sortBlock:[:a :b | (a name ? '?') < (b name ? '?')] ].
bucket add:cls.
] ifFalse:[
classesOrdered add:cls.
]
]
]
]
]
]
].
"/ are there any private classes, for which the owner is not in the list ?
privateClassesPerClass keysAndValuesDo:[:eachOwnerClass :privateClasses|
(classesAlready includes:eachOwnerClass) ifFalse:[
classesOrdered add:eachOwnerClass.
classesAlready add:eachOwnerClass.
"/ privateClasses do:[:privateClass |
"/ (classesOrdered includes:privateClass) ifFalse:[
"/ classesOrdered add:privateClass.
"/ ].
"/ ].
].
].
classesOrdered size == 1 ifTrue:[
self classLabelHolder value:(classesOrdered first name)
] ifFalse:[
"/ self classLabelHolder value:(classes size printString , ' classes').
sortBy value ~~ #doNotSort ifTrue:[
classesOrdered sort:[:a :b | a name < b name].
]
].
privateClassesPerClass notEmpty ifTrue:[
|stream action|
stream := WriteStream on:(Array new).
action :=
[:eachClass |
|bucket|
stream nextPut:eachClass.
bucket := privateClassesPerClass at:eachClass ifAbsent:nil.
bucket notNil ifTrue:[
bucket do:action.
]
].
classesOrdered do:action.
classesOrdered := stream contents.
].
"/
"/ does not work (yet)
"/ classes addFirst:AllEntry.
^ classesOrdered
"Modified: / 05-03-2007 / 16:58:12 / cg"
!
makeDependent
Smalltalk addDependent:self.
ChangeSet addDependent:self.
"Created: / 5.2.2000 / 13:42:17 / cg"
!
makeIndependent
Smalltalk removeDependent:self.
ChangeSet removeDependent:self.
!
nameListForClasses:aClassList
|orgMode namespaces showNamespaces fullNameList nameList
filteredPackages filteredNameSpaces classesInCangeSet classesInRemoteChangeSet
classNamesInChangeSet classNamesInRemoteChangeSet|
showNamespaces := false.
filteredNameSpaces := nameSpaceFilter value.
(filteredNameSpaces isNil
and:[self organizerMode value ~~ OrganizerCanvas organizerModeNamespace]) ifTrue:[
showNamespaces := true. "/ if no filter, always show the namespace.
] ifFalse:[
(filteredNameSpaces size > 1
or:[(filteredNameSpaces size > 0)
and:[filteredNameSpaces includes:(self class nameListEntryForALL)]]) ifTrue:[
showNamespaces := true
] ifFalse:[
"/ if there are classes from multiple namespaces,
"/ show the full name
namespaces := IdentitySet new.
fullNameList := OrderedCollection new.
aClassList
do:[:cls | |nm|
nm := cls nameInBrowser.
fullNameList add:nm.
namespaces add:cls topNameSpace.
].
showNamespaces := namespaces size > 1
].
].
orgMode := organizerMode value.
filteredPackages := packageFilter value value.
classesInCangeSet := ChangeSet current changedClasses.
classesInCangeSet := classesInCangeSet collect:[:each | each theNonMetaclass].
classNamesInChangeSet := classesInCangeSet collect:[:each | each name].
classesInRemoteChangeSet := SmallTeam isNil ifTrue:[#()] ifFalse:[ SmallTeam changedClasses ].
classesInRemoteChangeSet := classesInRemoteChangeSet collect:[:each | each theNonMetaclass].
classNamesInRemoteChangeSet := classesInRemoteChangeSet collect:[:each | each name].
nameList := aClassList
collect:[:cls |
|nm pkg emPkg hasExtensions isInChangeSet isInRemoteChangeSet icon
emp|
isInChangeSet := classNamesInChangeSet includes:(cls theNonMetaclass name).
isInRemoteChangeSet := classNamesInRemoteChangeSet includes:(cls theNonMetaclass name).
nm := self nameListEntryFor:cls withNameSpace:showNamespaces.
self showCoverageInformationHolder value ifTrue:[
emp := self emphasisForCoverageInformationOfClass:cls.
emp notNil ifTrue:[
nm := self colorize:nm with:emp
].
] ifFalse:[
isInChangeSet ifTrue:[
nm := self emphasizeForChangedCode:nm
].
isInRemoteChangeSet ifTrue:[
nm := (self colorizeForChangedCodeInSmallTeam:'!! '),nm
].
].
pkg := cls package ? '-'.
hasExtensions := cls hasExtensions.
hasExtensions ifTrue:[
emPkg := self emphasizeForDifferentPackage:'+'. "/ self emphasizeForDifferentPackage:pkg.
].
orgMode == OrganizerCanvas organizerModeProject ifTrue:[
(filteredPackages notNil
and:[(filteredPackages includes:cls package) not]) ifTrue:[
"/ class is in another packae;
"/ however, class is listed due to methods
"/ in the filtered package
hasExtensions ifTrue:[
nm := nm , emPkg.
] ifFalse:[
nm := nm , ' [ ' , pkg, ' ]'.
].
] ifFalse:[
"/ any methods from other packages in this class ?
hasExtensions ifTrue:[
nm := nm , (self emphasizeForDifferentPackage:'+').
].
].
] ifFalse:[
showClassPackages value == true ifTrue:[
"/ add the package;
hasExtensions ifTrue:[
nm := nm , ' [ ' , pkg, ' ]' , (self emphasizeForDifferentPackage:'+').
"/ isInChangeSet ifFalse:[
"/ nm := self colorizeForDifferentPackage:nm
"/ ].
] ifFalse:[
nm := nm , (self colorizeGrey:(' [ ' , pkg, ' ]')).
].
] ifFalse:[
hasExtensions ifTrue:[
nm := nm , emPkg.
"/ isInChangeSet ifFalse:[
"/ nm := self colorizeForDifferentPackage:nm
"/ ]
].
]
].
isInChangeSet ifTrue:[
nm := nm , self class markForBeingInChangeList
].
"/ cls isVisualStartable ifTrue:[
"/ nm := LabelAndIcon icon:((SystemBrowser visualStartableClassIcon)
"/ onDevice:self window device)
"/ string:nm
"/ ].
markApplicationsHolder value== true ifTrue:[
icon := self iconForClass:cls theNonMetaclass.
icon isNil ifTrue:[
icon := SystemBrowser emptyIcon
].
nm := LabelAndIcon icon:icon string:nm
].
nm
].
^ nameList
"Modified: / 27-04-2010 / 15:54:41 / cg"
!
reconstructNameList
"only reconstruct the names - class list & selection remains unschanged.
Invoked when the organizerMode mode changes"
|prevMode listView oldNameList newNameList sav|
self classList value isNil ifTrue:[
self updateList
].
newNameList := self nameListForClasses:(classList value ? #()).
oldNameList := self classNameList value ? #().
(newNameList
sameContentsAs: oldNameList
whenComparedWith:[:a :b | (a sameStringAndEmphasisAs: b)
and:[ a hasImage == b hasImage
and:[ a hasIcon == b hasIcon ]]]
)
ifTrue:[
"/ no need to update
] ifFalse:[
builder notNil ifTrue:[
listView := builder componentAt:#List.
].
(listView isNil or:[listView scrolledView isNil]) ifTrue:[
"/ invoked very early during setup
self classNameList value:newNameList
] ifFalse:[
"/ avoid flicker and useless redraws
prevMode := listView scrollWhenUpdating.
listView scrollWhenUpdating:nil.
"/ this will lead to a selectionIndex change (done by the selListView);
"/ however, we dont want this here, since it recurses into
"/ a selectionChange. Therefore, temporarily disconnect the selectionIndexHolder...
[
self selectedClassNameIndices removeDependent:self.
"/ also, dont want a callback (selectionChangedByClick)
sav := listView action.
listView action:nil.
self classNameList value:newNameList.
] ensure:[
listView action:sav.
self selectedClassNameIndices addDependent:self.
listView scrollWhenUpdating:prevMode.
].
]
].
"Modified: / 31.10.2001 / 11:33:21 / cg"
!
release
super release.
currentNamespace removeDependent:self.
hidePrivateClasses removeDependent:self.
markApplicationsHolder removeDependent:self.
meta removeDependent:self.
selectedClassNameIndices removeDependent:self.
showClassPackages removeDependent:self.
"Created: / 5.2.2000 / 13:42:18 / cg"
!
updateClassesIn:aCollection
"replace any obsolete class in aCollection;
return true, if any was found"
|found meta classes|
found := false.
aCollection isSequenceable ifFalse:[
classes := aCollection copy.
aCollection removeAll.
classes do:[:cls |
|newClass|
meta := cls isMeta.
newClass := Smalltalk at:(cls theNonMetaclass name).
newClass isNil ifTrue:[
newClass := cls
] ifFalse:[
meta ifTrue:[
newClass := newClass class
]
].
found := cls ~~ newClass.
aCollection add:newClass.
].
] ifTrue:[
aCollection keysAndValuesDo:[:idx :cls |
|newClass|
cls notNil ifTrue:[
meta := cls isMeta.
newClass := Smalltalk at:(cls theNonMetaclass name).
newClass isNil ifTrue:[
newClass := cls
] ifFalse:[
meta ifTrue:[
newClass := newClass class
]
].
found := cls ~~ newClass.
aCollection at:idx put:newClass.
]
].
].
^ found
!
updateList
|prevSelection oldList newList newSelectionIndices
forceSelectionChange selectedClassNameIndicesHolder classList
classesAddedToList classesRemovedFromList newSet oldSet|
newList := self listOfClasses.
classList := self classList.
oldList := classList value ? #().
autoSelect == true ifTrue:[
classesRemovedFromList := OrderedCollection new.
newSet := newList asSet.
oldSet := oldList asSet.
classesAddedToList := newSet select:[:eachNewClass | (oldSet includes:eachNewClass) not].
classesRemovedFromList := oldSet select:[:eachOldClass | (newSet includes:eachOldClass) not].
].
(newList ~= oldList
or:[self classNameList value isNil and:[newList size > 0]]) ifTrue:[
prevSelection := lastSelectedClasses ? #().
prevSelection := prevSelection select:[:each | each notNil].
(newList collect:[:each | each name]) = (oldList collect:[:each | each name]) ifTrue:[
"/ no need to tell anybody
classList setValue:newList.
] ifFalse:[
classList value:newList.
].
self reconstructNameList.
(prevSelection size == 0
and:[self selectedClasses value size ~~ 0]) ifTrue:[
"/ this happens during early startup time,
"/ when the selection is already (pre-)set,
"/ and the classList is generated the first time
"/ (i.e. when opened with preset selection)
"/ do not clobber the selection in this case.
prevSelection := self selectedClasses value.
prevSelection := prevSelection select:[:cls | cls notNil].
"/ simulate a change, to force selection update in listView
forceSelectionChange := true.
].
autoSelect == true ifTrue:[
prevSelection isNil ifTrue:[
prevSelection := OrderedCollection new
].
prevSelection := prevSelection asOrderedCollection.
classesAddedToList do:[:eachNewClass |
(prevSelection includes:eachNewClass) ifFalse:[
prevSelection add:eachNewClass.
].
].
classesRemovedFromList do:[:eachOldClass |
prevSelection remove:eachOldClass ifAbsent:[].
].
].
newSelectionIndices := prevSelection
collect:[:item | |cls|
cls := Smalltalk at:item theNonMetaclass name.
newList identityIndexOf:cls]
thenSelect:[:index | index ~~ 0].
selectedClassNameIndicesHolder := self selectedClassNameIndices.
((selectedClassNameIndicesHolder value size ~~ self selectedClasses value size)
or:[newSelectionIndices ~= selectedClassNameIndicesHolder value])
ifTrue:[
newSelectionIndices notEmpty ifTrue:[
"/ force change (for dependents)
"/ selectedClassNameIndicesHolder value:newSelectionIndices.
] ifFalse:[
prevSelection := self selectedClasses value.
newSelectionIndices := #().
].
selectedClassNameIndicesHolder value:newSelectionIndices.
prevSelection notNil ifTrue:[
lastSelectedClasses := prevSelection.
].
self updateOutputGenerator.
].
] ifFalse:[
"/ same classes - but name(s) could be differnet
newList size > 0 ifTrue:[
self reconstructNameList
]
].
listValid := true.
"Created: / 5.2.2000 / 13:42:18 / cg"
"Modified: / 31.10.2001 / 11:35:39 / cg"
!
updateListsFor:aClass
|classes found foundInSelection|
found := foundInSelection := false.
"/ update for a changed class in the classList
(classes := classList value) size > 0 ifTrue:[
(self updateClassesIn:classes) ifTrue:[
found := true
].
(classes includes:nil) ifTrue:[
"/ self halt:'should not happen'.
classList value:(classes := classes select:[:each | each notNil]).
].
].
"/ possibly in the generator
((classes := inGeneratorHolder value) isOrderedCollection
and:[classes size > 0]) ifTrue:[
(self updateClassesIn:classes) ifTrue:[
found := true
].
(classes includes:nil) ifTrue:[
"/ self halt:'should not happen'.
inGeneratorHolder value:(classes select:[:each | each notNil]).
]
].
"/ and in the selection
(classes := self selectedClasses value) size > 0 ifTrue:[
(self updateClassesIn:classes) ifTrue:[
found := true.
foundInSelection := true.
].
(classes includes:nil) ifTrue:[
"/ self halt:'should not happen'.
self selectedClasses value:(classes select:[:each | each notNil]).
]
].
"/ and in the last selection
(classes := lastSelectedClasses) size > 0 ifTrue:[
(self updateClassesIn:classes) ifTrue:[
found := true
].
(classes includes:nil) ifTrue:[
"/ self halt:'should not happen'.
lastSelectedClasses := (classes select:[:each | each notNil]).
]
].
found ifFalse:[
"/ could be a new class (or no-longer autolaoded one).
listValid ifTrue:[
self enqueueDelayedUpdateList.
].
listValid := false.
].
foundInSelection ifTrue:[
"/ force update of output generator
self selectedClasses
removeDependent:self;
changed;
addDependent:self.
].
"Modified: / 25.2.2000 / 23:54:19 / cg"
! !
!ClassList methodsFor:'private-presentation'!
emphasisForCoverageInformationOfClass:aClass
|instrumented anyPartiallyCovered anyCalled anyNotCalled|
instrumented := anyPartiallyCovered := anyCalled := anyNotCalled := false.
aClass instAndClassMethodsDo:[:m |
m isInstrumented ifTrue:[
instrumented := true.
m hasBeenCalled ifFalse:[
anyNotCalled := true.
] ifTrue:[
anyCalled := true.
m haveAllBlocksBeenExecuted ifFalse:[
anyPartiallyCovered := true.
"/ no need to search further...
^ UserPreferences current emphasisForInstrumentedPartiallyCoveredCode
]
].
].
].
instrumented ifFalse:[ ^ nil].
anyCalled ifFalse:[ ^ UserPreferences current emphasisForInstrumentedNeverCalledCode ].
anyNotCalled ifFalse:[ ^ UserPreferences current emphasisForInstrumentedFullyCoveredCode ].
^ UserPreferences current emphasisForInstrumentedPartiallyCoveredCode
"Created: / 27-04-2010 / 15:34:56 / cg"
!
iconForClass:aClass
^ SystemBrowser iconForClass:aClass
"Created: / 17-08-2006 / 09:12:32 / cg"
!
indentPerPrivacyLevel
^ 4
!
nameListEntryFor:aClass withNameSpace:useFullName
|nm indent owner orgMode indentString javaPackage|
aClass == (self class nameListEntryForALL) ifTrue:[ ^ aClass ].
nm := aClass nameInBrowser.
aClass isLoaded ifFalse:[
unloadedClassesColor notNil ifTrue:[
nm := nm colorizeAllWith:unloadedClassesColor
]
].
orgMode := organizerMode value.
orgMode == OrganizerCanvas organizerModeHierarchy ifTrue:[
"/ always show the full name
^ nm
].
orgMode == OrganizerCanvas organizerModeClassHierarchy ifTrue:[
"/ always show the full name
^ nm
].
aClass isJavaClass ifTrue:[
"/ only show the last name, unless multiple packages are shown in the list
javaPackage := aClass package.
(self classList value contains:[:cls | cls package ~= javaPackage]) ifTrue:[
^ nm
].
^ aClass lastName
].
useFullName ifFalse:[
aClass isPrivate ifFalse:[
^ aClass nameWithoutNameSpacePrefix
]
].
"/ full name required if owner is not in the list
owner := aClass owningClass.
(owner isNil
or:[(self classList value includesIdentical:owner) not]) ifTrue:[
^ nm
].
"/ namespace
indent := (nm count:[:char | char == $:]) // 2.
indent > 0 ifTrue:[
indent := indent * self indentPerPrivacyLevel.
indentString := String new:indent withAll:Character space.
nm := indentString , '::' , aClass nameWithoutPrefix
].
^ nm
"Modified: / 24.2.2000 / 17:52:28 / cg"
! !
!ClassList methodsFor:'setup'!
autoSelect:aBoolean
autoSelect ~~ aBoolean ifTrue:[
autoSelect := aBoolean.
classList value:nil.
].
!
classFilterBlock:aBlock
"use this to filter away unwanted packages"
classFilterBlock := aBlock
!
postBuildWith:aBuilder
|classListView|
super postBuildWith:aBuilder.
classListView := aBuilder componentAt:'List'.
classListView notNil ifTrue:[
classListView allowDrag:true.
classListView dragObjectConverter:[:obj |
|nm class idx|
nm := obj theObject asString.
idx := classNameList value indexOf:nm.
idx == 0 ifTrue:[
idx := classNameList value indexOf:nm string.
].
class := classList value at:idx.
DropObject newClass:class.
].
]
! !
!ClassList class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libtool/Tools_ClassList.st,v 1.45 2010-04-27 13:57:08 cg Exp $'
!
version_CVS
^ '$Header: /cvs/stx/stx/libtool/Tools_ClassList.st,v 1.45 2010-04-27 13:57:08 cg Exp $'
! !