"
COPYRIGHT (c) 2000 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:#MethodCategoryList
instanceVariableNames:'variableFilter filterClassVars lastSelectedProtocols classes
leafClasses protocolList rawProtocolList selectedProtocolIndices
lastGeneratedProtocols packageFilterOnInput
methodVisibilityHolder noAllItem noPseudoItems
showPseudoProtocols cachedMethodInfo'
classVariableNames:'AdditionalEmptyCategoriesPerClassName'
poolDictionaries:''
category:'Interface-Browsers-New'
!
Object subclass:#CachedMethodInfo
instanceVariableNames:'isObsolete sendsSuper isUncommented isDocumentationMethod'
classVariableNames:''
poolDictionaries:''
privateIn:MethodCategoryList
!
!MethodCategoryList class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2000 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.
"
! !
!MethodCategoryList class methodsFor:'interface specs'!
singleProtocolWindowSpec
"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:MethodCategoryList andSelector:#singleProtocolWindowSpec
MethodCategoryList new openInterface:#singleProtocolWindowSpec
"
<resource: #canvas>
^
#(#FullSpec
#name: #singleProtocolWindowSpec
#window:
#(#WindowSpec
#label: 'ProtocolList'
#name: 'ProtocolList'
#min: #(#Point 0 0)
#max: #(#Point 1024 721)
#bounds: #(#Rectangle 12 22 312 322)
)
#component:
#(#SpecCollection
#collection: #(
#(#LabelSpec
#label: 'ProtocolName'
#name: 'ProtocolLabel'
#layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0)
#translateLabel: true
#labelChannel: #protocolLabelHolder
#menu: #menuHolder
)
)
)
)
!
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:MethodCategoryList andSelector:#windowSpec
MethodCategoryList new openInterface:#windowSpec
MethodCategoryList open
"
<resource: #canvas>
^
#(#FullSpec
#name: #windowSpec
#window:
#(#WindowSpec
#label: 'ProtocolList'
#name: 'ProtocolList'
#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: #selectedProtocolIndices
#menu: #menuHolder
#hasHorizontalScrollBar: true
#hasVerticalScrollBar: true
#miniScrollerHorizontal: true
#isMultiSelect: true
#valueChangeSelector: #selectionChangedByClick
#useIndex: true
#sequenceList: #protocolList
#doubleClickChannel: #doubleClickChannel
#properties:
#(#PropertyListDictionary
#dragArgument: nil
#dropArgument: nil
#canDropSelector: #canDropContext:
#dropSelector: #doDropContext:
)
)
)
)
)
! !
!MethodCategoryList 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)."
^ #(
#(#doubleClickChannel #action )
#filterClassVars
#forceGeneratorTrigger
#immediateUpdate
#inGeneratorHolder
#menuHolder
#noAllItem
#showPseudoProtocols
#outGeneratorHolder
#packageFilter
#packageFilterOnInput
#selectedProtocols
#selectionChangeCondition
#updateTrigger
#variableFilter
#methodVisibilityHolder
).
! !
!MethodCategoryList methodsFor:'aspects'!
browserNameList
^ self protocolList
!
defaultSlaveModeValue
^ false.
!
filterClassVars
filterClassVars isNil ifTrue:[
filterClassVars := false asValue.
filterClassVars addDependent:self
].
^ filterClassVars
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
!
filterClassVars:aValueHolder
filterClassVars notNil ifTrue:[
filterClassVars removeDependent:self
].
filterClassVars := aValueHolder.
filterClassVars notNil ifTrue:[
filterClassVars addDependent:self
].
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
!
methodVisibilityHolder
methodVisibilityHolder isNil ifTrue:[
methodVisibilityHolder := false asValue.
methodVisibilityHolder addDependent:self
].
^ methodVisibilityHolder
!
methodVisibilityHolder:aValueHolder
methodVisibilityHolder notNil ifTrue:[
methodVisibilityHolder removeDependent:self
].
methodVisibilityHolder := aValueHolder.
methodVisibilityHolder notNil ifTrue:[
methodVisibilityHolder addDependent:self
].
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
!
noAllItem
noAllItem isNil ifTrue:[
noAllItem := false asValue.
noAllItem addDependent:self
].
^ noAllItem
!
noAllItem:aValueHolder
noAllItem notNil ifTrue:[
noAllItem removeDependent:self
].
noAllItem := aValueHolder.
noAllItem notNil ifTrue:[
noAllItem addDependent:self
].
!
packageFilterOnInput
packageFilterOnInput isNil ifTrue:[
packageFilterOnInput := nil asValue.
packageFilterOnInput addDependent:self
].
^ packageFilterOnInput
!
packageFilterOnInput:aValueHolder
|prevFilter|
prevFilter := packageFilterOnInput value.
packageFilterOnInput notNil ifTrue:[
packageFilterOnInput removeDependent:self
].
packageFilterOnInput := aValueHolder.
packageFilterOnInput notNil ifTrue:[
packageFilterOnInput addDependent:self
].
prevFilter ~= packageFilterOnInput value ifTrue:[
self enqueueDelayedUpdateList
].
!
protocolLabelHolder
^ self pseudoListLabelHolder
!
protocolList
protocolList isNil ifTrue:[
protocolList := List new. "/ ValueHolder new
].
^ protocolList
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
!
rawProtocolList
rawProtocolList isNil ifTrue:[
rawProtocolList := List new.
].
^ rawProtocolList
!
selectedProtocolIndices
selectedProtocolIndices isNil ifTrue:[
selectedProtocolIndices := ValueHolder new.
selectedProtocolIndices addDependent:self
].
^ selectedProtocolIndices.
!
selectedProtocols
^ self selectionHolder
!
selectedProtocols:aValueHolder
^ self selectionHolder:aValueHolder
!
showPseudoProtocols
showPseudoProtocols isNil ifTrue:[
showPseudoProtocols := true asValue.
showPseudoProtocols addDependent:self
].
^ showPseudoProtocols
!
showPseudoProtocols:aValueHolder
showPseudoProtocols notNil ifTrue:[
showPseudoProtocols removeDependent:self
].
showPseudoProtocols := aValueHolder.
showPseudoProtocols notNil ifTrue:[
showPseudoProtocols addDependent:self
].
!
variableFilter
variableFilter isNil ifTrue:[
variableFilter := false asValue.
variableFilter addDependent:self
].
^ variableFilter
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
!
variableFilter:aValueHolder
variableFilter notNil ifTrue:[
variableFilter removeDependent:self
].
variableFilter := aValueHolder.
variableFilter notNil ifTrue:[
variableFilter addDependent:self
].
"Modified: / 31.1.2000 / 00:56:31 / cg"
"Created: / 5.2.2000 / 13:42:10 / cg"
! !
!MethodCategoryList methodsFor:'change & update'!
classDefinitionChanged:aClass
|refetch anyChange|
anyChange := false.
refetch := [:oldClass |
|nm cls newClass|
nm := oldClass theNonMetaclass name.
oldClass isMeta ifTrue:[
newClass := Smalltalk at:nm.
newClass isNil ifTrue:[
Transcript showCR:'oops - browser lost class ' , nm.
newClass := oldClass
] ifFalse:[
newClass := newClass theMetaclass
]
] ifFalse:[
newClass := Smalltalk at:nm
].
newClass ~~ oldClass ifTrue:[
anyChange := true.
].
newClass
].
classes := classes collect:refetch.
leafClasses := leafClasses collect:refetch.
anyChange ifTrue:[
self updateOutputGenerator
].
!
delayedUpdate:something with:aParameter from:changedObject
|sel oldMethod newMethod mthd selectedCategories selectedProtocolsHolder oldProtocol newProtocol
rawProtocolListHolder rawProtocolList oldSelectedProtocols newSelectedProtocols newIndices idx cls listView|
selectedProtocolsHolder := self selectedProtocols.
rawProtocolListHolder := self rawProtocolList.
changedObject == Smalltalk ifTrue:[
classes notNil ifTrue:[
something == #methodCategory ifTrue:[
cls := aParameter at:1.
(cls notNil and:[classes includesIdentical:cls]) ifTrue:[
mthd := aParameter at:2.
newProtocol := mthd category.
oldProtocol := aParameter at:3.
self invalidateList.
selectedCategories := selectedProtocolsHolder value.
selectedCategories size > 0 ifTrue:[
selectedCategories := selectedCategories collect:[:each | each ifNil:[self class nameListEntryForNILCategory]].
selectedCategories := selectedCategories collect:[:each | each string].
((selectedCategories includes:oldProtocol)
or:[ (selectedCategories includes:newProtocol)
or:[ selectedCategories includes:(self class nameListEntryForALL) ]])
ifTrue:[
self updateOutputGenerator.
].
].
].
^ self
].
something == #methodInClass ifTrue:[
"/ a method has been added/removed/changed
cls := aParameter at:1.
(classes includesIdentical:cls) ifTrue:[
sel := aParameter at:2.
self flushMethodInfoForClassNamed:cls name selector:sel.
oldMethod := aParameter at:3.
newMethod := cls compiledMethodAt:sel.
oldMethod notNil ifTrue:[
variableFilter value size > 0 ifTrue:[
"/ sigh - must invalidate
self invalidateList.
].
^ self.
].
"/ method was added - update the methodList
"/ Q: is this needed (methodCategoryList should send me a new inGenerator)
self invalidateList.
"/ if its category is selected, updateOutputGenerator
selectedCategories := selectedProtocolsHolder value.
selectedCategories size > 0 ifTrue:[
selectedCategories := selectedCategories collect:[:each | each ifNil:[self class nameListEntryForNILCategory]].
selectedCategories := selectedCategories collect:[:each | each string].
((oldMethod notNil and:[selectedCategories includes:(oldMethod category)])
or:[ (newMethod notNil and:[selectedCategories includes:(newMethod category)])])
ifTrue:[
self updateOutputGenerator.
].
].
].
^ self.
].
something == #methodInClassRemoved ifTrue:[
cls := aParameter at:1.
(classes includesIdentical:cls) ifTrue:[
sel := aParameter at:2.
self flushMethodInfoForClassNamed:cls name selector:sel.
"/ method was removed - update the list and output generator
self invalidateList.
"/ self updateOutputGenerator.
self slaveMode value == true ifFalse:[
self enqueueDelayedUpdateOutputGenerator.
]
].
^ self.
].
(something == #classOrganization
or:[ something == #methodCategoryAdded
or:[ something == #methodCategoryRemoved
or:[ something == #methodCategoriesRemoved
or:[ something == #methodCategoryRenamed ]]]]) ifTrue:[
cls := (something == #classOrganization) ifTrue:aParameter ifFalse:[aParameter first].
(classes includesIdentical:cls) ifTrue:[
self invalidateList.
] ifFalse:[
(classes contains:[:aClass | aClass name = cls name]) ifTrue:[
self invalidateList.
"/ self error:'obsolete class: should not happen'.
]
].
^ self.
].
something == #projectOrganization ifTrue:[
aParameter notNil ifTrue:[
cls := aParameter at:1.
cls notNil ifTrue:[
((classes includes:cls theMetaclass)
or:[(classes includes:cls theNonMetaclass)]) ifTrue:[
self invalidateList.
self slaveMode value == true ifFalse:[
self enqueueDelayedUpdateOutputGenerator.
]
].
].
] ifFalse:[
self invalidateList.
].
^ self
].
(something == #classDefinition or:[something == #classVariables])
ifTrue:[
self classDefinitionChanged:aParameter.
^ self
].
"/ everything else is ignored
"/ self halt.
].
^ self
].
changedObject == self selectedProtocolIndices ifTrue:[
oldSelectedProtocols := selectedProtocolsHolder value ? #().
oldSelectedProtocols := oldSelectedProtocols collect:[:each | each ifNil:[self class nameListEntryForNILCategory]].
oldSelectedProtocols := oldSelectedProtocols collect:[:each | each string].
newSelectedProtocols := self getSelectedProtocolsFromIndices.
oldSelectedProtocols ~= newSelectedProtocols ifTrue:[
selectedProtocolsHolder value:newSelectedProtocols.
].
newSelectedProtocols size > 1 ifTrue:[
(newSelectedProtocols includes:(self class nameListEntryForALL)) ifTrue:[
rawProtocolList := rawProtocolListHolder value.
idx := rawProtocolList indexOf: (newSelectedProtocols copy remove:(self class nameListEntryForALL); yourself) first.
idx ~~ 0 ifTrue:[
(listView := self componentAt:#List) notNil ifTrue:[
listView makeLineVisible:idx.
]
]
]
].
^ self
].
changedObject == selectedProtocolsHolder ifTrue:[
rawProtocolList := rawProtocolListHolder value.
rawProtocolList size == 0 ifTrue:[
self updateList.
rawProtocolList := rawProtocolListHolder value.
].
rawProtocolList notNil ifTrue:[
selectedCategories := selectedProtocolsHolder value ? #().
selectedCategories := selectedCategories collect:[:each | each ifNil:[self class nameListEntryForNILCategory]].
newIndices := selectedCategories
collect:[:each | rawProtocolList findFirst:[:p | p string = each string]].
newIndices := newIndices select:[:each | each ~~ 0].
newIndices ~= self selectedProtocolIndices value ifTrue:[
self selectedProtocolIndices setValue:nil. "/ to force update
self selectedProtocolIndices value:newIndices
].
(lastGeneratedProtocols notNil
and:[(lastGeneratedProtocols includes:self class nameListEntryForALL)
and:[(selectedProtocolsHolder value ? #()) includes:self class nameListEntryForALL]])
ifTrue:[
"/ no need to update generator
] ifFalse:[
self updateOutputGenerator.
]
].
^ self
].
(changedObject == variableFilter
or:[changedObject == filterClassVars
or:[changedObject == packageFilterOnInput]]) ifTrue:[
self invalidateList.
^ self
].
changedObject == methodVisibilityHolder ifTrue:[
self invalidateList.
self updateOutputGenerator.
^ self
].
lastGeneratedProtocols := nil.
changedObject == inGeneratorHolder ifTrue:[
selectedCategories := selectedProtocolsHolder value.
selectedCategories size > 0 ifTrue:[
oldSelectedProtocols := selectedCategories ? #().
oldSelectedProtocols := oldSelectedProtocols collect:[:each | each ifNil:[self class nameListEntryForNILCategory]].
oldSelectedProtocols := oldSelectedProtocols collect:[:each | each string].
self updateList.
rawProtocolList := rawProtocolListHolder value.
newSelectedProtocols := oldSelectedProtocols select:[:each | rawProtocolList includes:each].
"/ selectedProtocolsHolder setValue:nil. "/ to force update
selectedProtocolsHolder value:newSelectedProtocols.
^ self
].
].
super delayedUpdate:something with:aParameter from:changedObject
"Created: / 5.2.2000 / 13:42:10 / cg"
"Modified: / 29.2.2000 / 11:11:39 / cg"
!
getSelectedProtocolsFromIndices
|l|
l := self rawProtocolList value.
^ self selectedProtocolIndices value collect:[:idx | l at:idx].
!
selectionChanged
|newSelectedCategories allEntry|
newSelectedCategories := self selectedProtocols value.
"/ the outputGenerator is only to be updated, if the output would really
"/ change ...
allEntry := self class nameListEntryForALL.
(lastSelectedProtocols notNil
and:[newSelectedCategories notNil
and:[(lastSelectedProtocols includes:(allEntry))
and:[newSelectedCategories includes:(allEntry)]]]) ifTrue:[
"/ no change ...
^ self
].
super selectionChanged.
"Created: / 5.2.2000 / 13:42:10 / cg"
"Modified: / 24.2.2000 / 14:12:12 / cg"
!
selectionChangedByClick
"we are not interested in that - get another notification
via the changed valueHolder"
lastSelectedProtocols := self getSelectedProtocolsFromIndices
!
update:something with:aParameter from:changedObject
|cls sel oldMethod newMethod|
"/ some can be ignored immediately
changedObject == Smalltalk ifTrue:[
something isNil ifTrue:[
"/ self halt "/ huh - Smalltalk changed - so what ?
^ self.
].
something == #currentChangeSet ifTrue:[
self invalidateList.
^ self.
].
something == #methodInClass ifTrue:[
"/ a method has been added/removed/changed
cls := aParameter at:1.
(classes notNil and:[classes includesIdentical:cls]) ifFalse:[^ self].
sel := aParameter at:2.
self flushMethodInfoForClassNamed:cls name selector:sel.
oldMethod := aParameter at:3.
newMethod := cls compiledMethodAt:sel.
oldMethod notNil ifTrue:[
variableFilter value size > 0 ifTrue:[
"/ sigh - must invalidate
self invalidateList.
^ self.
].
oldMethod category ~= newMethod category ifTrue:[
self invalidateList.
^ self.
].
"/ mhmh - its now changed (so coloring will change).
self invalidateList.
^ self.
].
].
"/ something == #classDefinition ifTrue:[
"/ ^ self.
"/ ].
something == #newClass ifTrue:[
^ self.
].
something == #classRemove ifTrue:[
^ self.
].
something == #classRename ifTrue:[
^ self.
].
"/ something == #classVariables ifTrue:[
"/ ^ self.
"/ ].
something == #classComment ifTrue:[
^ self.
].
something == #organization ifTrue:[
^ self.
].
something == #methodTrap ifTrue:[
^ self
].
].
super update:something with:aParameter from:changedObject.
"Modified: / 10-08-2006 / 17:23:48 / cg"
! !
!MethodCategoryList methodsFor:'drag & drop'!
canDropContext:aDropContext
|cat methods|
methods := aDropContext dropObjects collect:[:obj | obj theObject].
(methods conform:[:aMethod | aMethod isMethod]) ifFalse:[^ false].
cat := self categoryAtTargetPointOf:aDropContext.
cat isNil ifTrue:[^ false].
(methods contains:[:aMethod | aMethod category ~= cat]) ifFalse:[^ false].
^ true
"Modified: / 13-09-2006 / 11:44:02 / cg"
!
categoryAtTargetPointOf:aDropContext
|p methodListView lineNr cat|
p := aDropContext targetPoint.
methodListView := aDropContext targetWidget.
lineNr := methodListView lineAtY:p y.
lineNr isNil ifTrue:[^ nil].
cat := rawProtocolList at:lineNr.
cat := cat string.
cat = self class nameListEntryForALL ifTrue:[^ nil].
^ cat
!
doDropContext:aDropContext
|cat methods|
methods := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
(methods conform:[:something | something isMethod]) ifFalse:[^ self].
cat := self categoryAtTargetPointOf:aDropContext.
cat notNil ifTrue:[
self masterApplication moveMethods:methods toProtocol:cat.
].
"Modified: / 13-09-2006 / 11:43:23 / cg"
! !
!MethodCategoryList methodsFor:'generators'!
makeGenerator
"return a generator which enumerates the methods from the selected protocol;
that generator generates 4-element elements (includes the class and protocol),
in order to make the consumers only depend on one input
(i.e. to pass multiple-class and multiple-protocol info
without a need for another classHolder/protocolHolder in the methodList)."
^ Iterator
on:[:whatToDo |
|protocols
allProtocols superSendProtocols uncommentedProtocols obsoleteProtocols documentationProtocols
noCat static notStatic classSelectorPairsAlreadyDone
packages remainingClasses remainingCategories classesAlreadyDone noPackage|
noPackage := Project noProjectID.
noCat := (self class nameListEntryForNILCategory).
static := (self class nameListEntryForStatic).
notStatic := (self class nameListEntryForNonStatic).
protocols := self selectedProtocols value ? #().
protocols := protocols collect:[:each | (each ifNil:[noCat]) string].
lastGeneratedProtocols := protocols.
protocols := protocols asSet.
(leafClasses size > 0 and:[protocols size > 0]) ifTrue:[
allProtocols := protocols includes:(self class nameListEntryForALL).
superSendProtocols := protocols includes:(self class nameListEntryForSuperSend).
uncommentedProtocols := protocols includes:(self class nameListEntryForUncommented).
obsoleteProtocols := protocols includes:(self class nameListEntryForObsolete).
documentationProtocols := protocols includes:(self class nameListEntryForDocumentation).
"/ packages := packageFilter value value.
"/ (packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
"/ packages := nil.
"/ ].
remainingClasses := leafClasses copy asIdentitySet.
remainingCategories := protocols copy asSet.
classesAlreadyDone := IdentitySet new.
classSelectorPairsAlreadyDone := Set new.
leafClasses do:[:aLeafClass |
(self classesToProcessForClasses:(Array with:aLeafClass)) do:[:aClass |
|supportsMethodCategories isJavaClass anyInThisClass|
(classesAlreadyDone includes:aClass) ifFalse:[
classesAlreadyDone add:aClass.
supportsMethodCategories := aClass supportsMethodCategories.
isJavaClass := aClass isJavaClass.
anyInThisClass := false.
aClass methodDictionary keysAndValuesDo:[:sel :mthd |
|cat mPkg includeIt info|
supportsMethodCategories ifTrue:[
cat := mthd category.
] ifFalse:[
isJavaClass ifTrue:[
cat := mthd isStatic ifTrue:[static] ifFalse:[notStatic]
] ifFalse:[
cat := noCat.
]
].
mPkg := mthd package.
(packages isNil or:[mPkg = noPackage or:[packages includes:mPkg]])
ifTrue:[
"/ used to be a more readable or, but to reuse info, I've splitted it.
"/ because we should use the parser only once, we reuse the same methodInfo.
"/ otherwise, the list update becomes too slow for long classes (NewSystemBrowser)
includeIt := allProtocols.
includeIt ifFalse:[ includeIt := protocols includes:cat ].
includeIt ifFalse:[
superSendProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd ].
includeIt := info sendsSuper ]].
includeIt ifFalse:[
uncommentedProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd ].
includeIt := info isUncommented ]].
includeIt ifFalse:[
obsoleteProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd ].
includeIt := info isObsolete ]].
includeIt ifFalse:[
documentationProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd ].
includeIt := info isDocumentationMethod ]].
includeIt ifTrue:[
(methodVisibilityHolder value == #class) ifTrue:[
whatToDo value:aClass value:cat value:sel value:mthd.
] ifFalse:[
(classSelectorPairsAlreadyDone includes:(aLeafClass->sel)) ifFalse:[
classSelectorPairsAlreadyDone add:(aLeafClass->sel).
whatToDo value:aClass value:cat value:sel value:mthd.
].
].
anyInThisClass := true.
remainingCategories remove:cat ifAbsent:nil.
]
]
].
anyInThisClass ifTrue:[ remainingClasses remove:aClass ifAbsent:nil. ].
].
].
].
remainingClasses do:[:aClass |
whatToDo value:aClass value:nil value:nil value:nil.
].
remainingCategories do:[:cat |
whatToDo value:nil value:cat value:nil value:nil.
]
]
]
"Created: / 05-02-2000 / 13:42:10 / cg"
"Modified: / 13-10-2006 / 01:16:17 / cg"
! !
!MethodCategoryList methodsFor:'private'!
class:cls protocol:cat includesMethodsInAnyPackage:packageFilter
cls methodDictionary keysAndValuesDo:[:sel :mthd |
mthd category == cat ifTrue:[
(packageFilter includes:mthd package) ifTrue:[
^ true
]
]
].
^ false
!
class:cls protocol:cat includesModsOfClassVariable:variablesToHighLight
^ self class:cls protocol:cat includesRefsToVariable:variablesToHighLight askParserWith:#modifiedClassVars
!
class:cls protocol:cat includesModsOfInstanceVariable:variablesToHighLight
^ self class:cls protocol:cat includesRefsToVariable:variablesToHighLight askParserWith:#modifiedInstVars
!
class:cls protocol:cat includesRefsToClassVariable:variablesToHighLight
^ self class:cls protocol:cat includesRefsToVariable:variablesToHighLight askParserWith:#usedClassVars
!
class:cls protocol:cat includesRefsToInstanceVariable:variablesToHighLight
^ self class:cls protocol:cat includesRefsToVariable:variablesToHighLight askParserWith:#usedInstVars
!
class:cls protocol:cat includesRefsToVariable:variablesToHighLight askParserWith:querySelector
|anyVarNameAccessable|
anyVarNameAccessable := cls allInstVarNames includesAny:variablesToHighLight.
anyVarNameAccessable ifFalse:[
anyVarNameAccessable := cls theNonMetaclass allClassVarNames includesAny:variablesToHighLight.
].
anyVarNameAccessable ifFalse:[
"/ no need to parse
^ false
].
cls selectorsAndMethodsDo:[:sel :mthd |
|src parser usedVars|
mthd category = cat ifTrue:[
src := mthd source.
src notNil ifTrue:[
"
before doing a slow parse, quickly scan the
methods source for the variables name ...
"
(variablesToHighLight contains:[:varName | (src findString:varName) ~~ 0]) ifTrue:[
parser := Parser
parseMethod:src
in:cls
ignoreErrors:true
ignoreWarnings:true.
(parser notNil and:[parser ~~ #Error]) ifTrue:[
usedVars := parser perform:querySelector.
(usedVars includesAny:variablesToHighLight)
ifTrue:[
^ true
]
]
]
] ifFalse:[
Transcript showCR:'Oops - cannot access methods source'.
]
]
].
^ false
!
classesToProcessForClasses:classes
^ self classesToProcessForClasses:classes withVisibility:methodVisibilityHolder value.
!
flushMethodInfoForClassNamed:className selector:selector
cachedMethodInfo isNil ifTrue:[ ^ self ].
^ cachedMethodInfo
removeKey:(className,'>>',selector)
ifAbsent:[]
!
listOfMethodCategories
|categoryList plainCategories classesProcessed leafClassesProcessed
generator nm variablesToHighlight classVarsToHighLight
itemsWithVarRefs itemsWithVarMods itemsWithExtensions itemsWithSuppressedExtensions
itemsInChangeSet itemsInRemoteChangeSet
packageFilterOnInput packageFilter nameListEntryForALL changeSet
emphasizedPlus emphasisForRef emphasisForMod
numObsolete numSuper numUncommented numDocumentation|
generator := inGeneratorHolder value.
generator isNil ifTrue:[ ^ #() ].
nameListEntryForALL := self class nameListEntryForALL.
packageFilterOnInput := self packageFilterOnInput value.
(packageFilterOnInput notNil and:[packageFilterOnInput includes:nameListEntryForALL]) ifTrue:[
packageFilterOnInput := nil
].
packageFilter := self packageFilter value.
(packageFilter notNil and:[packageFilter includes:nameListEntryForALL]) ifTrue:[
packageFilter := nil
].
categoryList := Set new.
itemsWithVarRefs := Set new.
itemsWithVarMods := Set new.
itemsWithExtensions := Set new.
itemsWithSuppressedExtensions := Set new.
itemsInChangeSet := Set new.
itemsInRemoteChangeSet := Set new.
plainCategories := Set new.
classesProcessed := IdentitySet new.
leafClassesProcessed := IdentitySet new.
variablesToHighlight := variableFilter value.
classVarsToHighLight := filterClassVars value.
numObsolete := numSuper := numUncommented := numDocumentation := 0.
generator do:[:clsIn :catIn |
|emptyProtocols clsName doHighLight doHighLightRed suppress|
leafClassesProcessed add:clsIn.
(self classesToProcessForClasses:(Array with:clsIn)) do:[:cls |
|cats|
classesProcessed add:cls.
cls ~~ clsIn ifTrue:[
cats := cls categories
] ifFalse:[
cats := Array with:catIn.
].
cats do:[:cat |
cat notNil ifTrue:[
suppress := packageFilterOnInput notNil
and:[ (self class:cls protocol:cat includesMethodsInAnyPackage:packageFilterOnInput) not ].
suppress ifFalse:[
variablesToHighlight notEmptyOrNil ifTrue:[
(itemsWithVarRefs includes:cat) ifFalse:[
classVarsToHighLight ifTrue:[
doHighLight := self class:cls protocol:cat includesRefsToClassVariable:variablesToHighlight.
doHighLight ifTrue:[
doHighLightRed := self class:cls protocol:cat includesModsOfClassVariable:variablesToHighlight.
].
] ifFalse:[
doHighLight := self class:cls protocol:cat includesRefsToInstanceVariable:variablesToHighlight.
doHighLight ifTrue:[
doHighLightRed := self class:cls protocol:cat includesModsOfInstanceVariable:variablesToHighlight.
].
].
doHighLight ifTrue:[
itemsWithVarRefs add:cat.
doHighLightRed ifTrue:[
itemsWithVarMods add:cat.
].
]
]
].
self showPseudoProtocols value ifTrue:[
cls selectorsAndMethodsDo:[:sel :mthd |
|info|
mthd category = cat ifTrue:[
info := self methodInfoFor:mthd.
info isObsolete ifTrue:[ numObsolete := numObsolete + 1 ].
info sendsSuper ifTrue:[ numSuper := numSuper + 1 ].
info isUncommented ifTrue:[ numUncommented := numUncommented + 1 ].
info isDocumentationMethod ifTrue:[ numDocumentation := numDocumentation + 1 ].
]
].
].
categoryList add:cat.
AdditionalEmptyCategoriesPerClassName size > 0 ifTrue:[
clsName := cls name.
emptyProtocols := AdditionalEmptyCategoriesPerClassName at:clsName ifAbsent:nil.
emptyProtocols size > 0 ifTrue:[
emptyProtocols remove:cat ifAbsent:nil.
].
emptyProtocols size == 0 ifTrue:[
AdditionalEmptyCategoriesPerClassName removeKey:clsName ifAbsent:nil
].
].
]
]
]
]
].
changeSet := ChangeSet current.
classesProcessed do:[:eachClass |
|classPackage|
classPackage := eachClass package.
eachClass methodDictionary keysAndValuesDo:[:mSelector :mthd |
|mPackage mCategory|
mPackage := mthd package.
mCategory := mthd category.
#fixme.
mPackage = classPackage ifTrue:[
mPackage ~~ classPackage ifTrue:[
mthd setPackage:(mPackage := mPackage string asSymbol).
]
].
mPackage ~~ classPackage ifTrue:[
mPackage ~= Project noProjectID ifTrue:[
itemsWithExtensions add:mCategory.
(packageFilter notNil
and:[ (packageFilter includes:mPackage) not])
ifTrue:[
itemsWithSuppressedExtensions add:mCategory.
].
].
].
(changeSet includesChangeForClass:eachClass selector:mSelector) ifTrue:[
itemsInChangeSet add:mCategory.
].
(SmallTeam notNil and:[ SmallTeam includesChangeForClass:eachClass selector:mSelector] ) ifTrue:[
itemsInRemoteChangeSet add:mCategory.
].
]
].
categoryList := categoryList asOrderedCollection.
self rawProtocolList removeAll.
rawProtocolList addAll:categoryList.
emphasizedPlus := (self colorizeForDifferentPackage:' [ + ]').
emphasisForRef := UserPreferences current emphasisForReadVariable.
emphasisForMod := UserPreferences current emphasisForWrittenVariable.
(itemsInChangeSet notEmpty
or:[itemsInRemoteChangeSet notEmpty
or:[itemsWithExtensions notEmpty
or:[itemsWithVarRefs notEmpty]] ]) ifTrue:[
rawProtocolList keysAndValuesDo:[:idx :cat |
|item inChangeSet inRemoteChangeSet hasExtensions hasVarRef hasVarMod|
item := cat.
inChangeSet := itemsInChangeSet includes:cat.
inChangeSet ifTrue:[
item := self colorizeForChangedCode:cat.
].
inRemoteChangeSet := itemsInRemoteChangeSet includes:cat.
inRemoteChangeSet ifTrue:[
item := (self colorizeForChangedCodeInSmallTeam:'!! '),item.
].
hasVarRef := itemsWithVarRefs includes:cat.
hasVarRef ifTrue:[
hasVarMod := itemsWithVarMods includes:cat.
item := item asText
emphasisAllAdd:(hasVarMod ifTrue:emphasisForMod ifFalse:emphasisForRef).
].
hasExtensions := itemsWithExtensions includes:cat.
hasExtensions ifTrue:[
item := item , emphasizedPlus.
].
inChangeSet ifTrue:[
item := item , self class markForBeingInChangeList.
].
categoryList at:idx put:item.
]
].
classesProcessed size > 0 ifTrue:[
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName size > 0 ifTrue:[
AdditionalEmptyCategoriesPerClassName keysAndValuesDo:[:clsName :protocols |
(classesProcessed contains:[:cls | cls name = clsName]) ifTrue:[
categoryList addAll:protocols.
rawProtocolList addAll:protocols.
]
]
].
].
self makeIndependent.
classes := classesProcessed.
leafClasses := leafClassesProcessed.
self makeDependent.
rawProtocolList sortWith:categoryList.
categoryList size == 1 ifTrue:[
nm := categoryList first string.
classes size == 1 ifTrue:[
nm := classes first name , '-' , nm
].
self protocolLabelHolder value:nm
].
categoryList notEmpty ifTrue:[
noAllItem value ~~ true ifTrue:[
categoryList addFirst:(nameListEntryForALL asText allItalic).
rawProtocolList addFirst:nameListEntryForALL.
].
self showPseudoProtocols value ifTrue:[
numSuper > 0 ifTrue:[
categoryList add:((self class nameListEntryForSuperSend bindWith:numSuper) asText allItalic).
rawProtocolList add:self class nameListEntryForSuperSend.
].
numDocumentation > 0 ifTrue:[
categoryList add:((self class nameListEntryForDocumentation bindWith:numDocumentation) asText allItalic).
rawProtocolList add:self class nameListEntryForDocumentation.
].
numUncommented > 0 ifTrue:[
categoryList add:((self class nameListEntryForUncommented bindWith:numUncommented) asText allItalic).
rawProtocolList add:self class nameListEntryForUncommented.
].
numObsolete > 0 ifTrue:[
categoryList add:((self class nameListEntryForObsolete bindWith:numObsolete) asText allItalic).
rawProtocolList add:self class nameListEntryForObsolete.
].
].
].
^ categoryList
"Created: / 05-02-2000 / 13:42:11 / cg"
"Modified: / 10-11-2006 / 17:35:53 / cg"
!
makeDependent
Smalltalk addDependent:self.
"/ ChangeSet addDependent:self.
"Modified: / 10-11-2006 / 17:57:13 / cg"
!
makeIndependent
Smalltalk removeDependent:self.
"/ ChangeSet removeDependent:self.
!
methodInfoFor:aMethod
cachedMethodInfo isNil ifTrue:[ cachedMethodInfo := Dictionary new ].
^ cachedMethodInfo
at:(aMethod mclass name,'>>',aMethod selector)
ifAbsentPut:[
|info|
true "aMethod mclass language isSmalltalk" ifTrue:[
info := CachedMethodInfo new.
info isObsolete:(aMethod isObsolete).
info sendsSuper:(aMethod superMessages notEmptyOrNil).
info isUncommented:(aMethod comment isEmptyOrNil and:[aMethod isVersionMethod not]).
info isDocumentationMethod:( aMethod isDocumentationMethod).
].
info
]
!
release
super release.
filterClassVars removeDependent:self.
methodVisibilityHolder removeDependent:self.
noAllItem removeDependent:self.
packageFilterOnInput removeDependent:self.
selectedProtocolIndices removeDependent:self.
variableFilter removeDependent:self.
!
updateList
|prevClasses prevSelection newSelection newList oldList sameContents selectedProtocolsHolder rawList|
selectedProtocolsHolder := self selectedProtocols.
prevClasses := classes ifNil:[ #() ] ifNotNil:[ classes copy ].
oldList := self protocolList value copy.
newList := self listOfMethodCategories.
"/ oldListSize := self browserNameList size.
"/ newListSize := newList size.
self selectedProtocolIndices removeDependent:self.
sameContents := self updateListFor:newList.
self selectedProtocolIndices addDependent:self.
sameContents ifFalse:[
prevSelection := lastSelectedProtocols ? (selectedProtocolsHolder value) ? #().
"/ prevSelection := selectedProtocolsHolder value ? lastSelectedProtocols ? #().
rawList := self rawProtocolList value.
newSelection := prevSelection select:[:item | rawList includes:item string].
newSelection size > 0 ifTrue:[
"/ force change (for dependents)
"/ selectedProtocolsHolder value:nil.
"/ selectedProtocolsHolder value:newSelection.
selectedProtocolsHolder setValue:newSelection.
selectedProtocolsHolder changed:#value.
] ifFalse:[
prevSelection := selectedProtocolsHolder value.
selectedProtocolsHolder value:nil.
].
(prevSelection size > 0 or:[newSelection size > 0]) ifTrue:[
self enqueueDelayedUpdateOutputGenerator.
"/ self updateOutputGenerator.
].
"/ prevSelection notNil ifTrue:[
"/ lastSelectedProtocols := prevSelection.
"/ ].
] ifTrue:[
"/ same list - but classes might have changed
"/ that is the case, if the class selection has been changed,
"/ to another class which has the same categories.
(prevClasses size ~= classes size
or:[prevClasses asOrderedCollection ~= (classes ? #()) asOrderedCollection ]) ifTrue:[
(newList size > 0 or:[oldList size > 0]) ifTrue:[
self updateOutputGenerator
]
] ifFalse:[
"/ self protocolList value:newList.
]
].
listValid := true.
"Created: / 5.2.2000 / 13:42:11 / cg"
"Modified: / 29.2.2000 / 11:08:55 / cg"
! !
!MethodCategoryList methodsFor:'special'!
addAdditionalProtocol:aProtocol forClass:aClass
|categories|
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName isNil ifTrue:[
AdditionalEmptyCategoriesPerClassName := Dictionary new.
].
categories := AdditionalEmptyCategoriesPerClassName at:aClass name ifAbsent:nil.
categories isNil ifTrue:[
categories := Set new.
AdditionalEmptyCategoriesPerClassName at:aClass name put:categories.
].
categories add:aProtocol.
aClass changed:#organization. "/ not really ... to force update
Smalltalk changed:#methodCategoryAdded with:(Array with:aClass with:aProtocol). "/ not really ... to force update
!
additionalProtocolForClass:aClass
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName isNil ifTrue:[ ^ #() ].
^ AdditionalEmptyCategoriesPerClassName at:aClass name ifAbsent:[ #() ].
!
clearLastSelectedProtocol
lastSelectedProtocols := nil
!
lastSelectedProtocols
^ lastSelectedProtocols
!
removeAdditionalProtocol:aListOfProtocols forClass:aClass
|categories|
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName isNil ifTrue:[^ self].
categories := AdditionalEmptyCategoriesPerClassName at:aClass name ifAbsent:nil.
categories isNil ifTrue:[^ self].
categories removeAllFoundIn:aListOfProtocols.
categories isEmpty ifTrue:[
AdditionalEmptyCategoriesPerClassName removeKey:aClass name.
].
aClass changed:#organization. "/ not really ... to force update
Smalltalk changed:#methodCategoriesRemoved with:(Array with:aClass with:aListOfProtocols). "/ not really ... to force update
!
removeAllAdditionalProtocol
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName := nil
!
removeAllAdditionalProtocolForClass:aClass
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName notNil ifTrue:[
AdditionalEmptyCategoriesPerClassName removeKey:aClass name ifAbsent:nil
].
!
renameAdditionalProtocol:oldName to:newName forClass:aClass
|categories|
"/ those are simulated - in ST/X, empty categories do not
"/ really exist; however, during browsing, it makes sense.
AdditionalEmptyCategoriesPerClassName isNil ifTrue:[^ self].
categories := AdditionalEmptyCategoriesPerClassName at:aClass name ifAbsent:nil.
categories isNil ifTrue:[^ self].
categories remove:oldName ifAbsent:nil.
categories add:newName.
aClass changed:#organization. "/ not really ... to force update
Smalltalk changed:#methodCategoryRenamed with:(Array with:aClass with:oldName with:newName). "/ not really ... to force update
! !
!MethodCategoryList::CachedMethodInfo methodsFor:'accessing'!
isDocumentationMethod
^ isDocumentationMethod
!
isDocumentationMethod:aBoolean
isDocumentationMethod := aBoolean.
!
isObsolete
^ isObsolete
!
isObsolete:aBoolean
isObsolete := aBoolean.
!
isUncommented
^ isUncommented
!
isUncommented:aBoolean
isUncommented := aBoolean.
!
sendsSuper
^ sendsSuper
!
sendsSuper:aBoolean
sendsSuper := aBoolean.
! !
!MethodCategoryList class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.32 2009-10-02 09:19:21 cg Exp $'
!
version_CVS
^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.32 2009-10-02 09:19:21 cg Exp $'
! !