"
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:#MethodList
instanceVariableNames:'classes selectedMethodNameIndices methodList lastSelectedMethods
browserNameList variableFilter filterClassVars updateProcess
lastShowClass lastShowCategory lastShowClassFirst
showMethodInheritance lastMethodClass lastMethodClassesSubclasses
classAndSelectorsRedefinedBySubclassesOfClass showClass
showMethodComplexity showMethodTypeIcon
showImageResourceMethodsImages showCoverageInformation'
classVariableNames:'ShowComplexityValue'
poolDictionaries:''
category:'Interface-Browsers-New'
!
!MethodList 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.
"
! !
!MethodList class methodsFor:'interface specs'!
singleMethodWindowSpec
"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:MethodList andSelector:#singleMethodWindowSpec
MethodList new openInterface:#singleMethodWindowSpec
"
<resource: #canvas>
^
#(#FullSpec
#name: #singleMethodWindowSpec
#window:
#(#WindowSpec
#label: 'SingleSelectorList'
#name: 'SingleSelectorList'
#min: #(#Point 0 0)
#max: #(#Point 1024 721)
#bounds: #(#Rectangle 12 22 312 322)
)
#component:
#(#SpecCollection
#collection: #(
#(#LabelSpec
#label: 'MethodName'
#name: 'MethodLabel'
#layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0)
#translateLabel: true
#labelChannel: #methodLabelHolder
#menu: #menuHolder
)
)
)
)
"Modified: / 1.3.2000 / 20:50:15 / cg"
!
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:MethodList andSelector:#windowSpec
MethodList new openInterface:#windowSpec
MethodList open
"
<resource: #canvas>
^
#(#FullSpec
#name: #windowSpec
#window:
#(#WindowSpec
#label: 'SelectorList'
#name: 'SelectorList'
#min: #(#Point 0 0)
#bounds: #(#Rectangle 12 22 312 322)
)
#component:
#(#SpecCollection
#collection: #(
#(#SequenceViewSpec
#name: 'List'
#layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 0 1.0)
#tabable: true
#model: #selectedMethodNameIndices
#menu: #menuHolder
#hasHorizontalScrollBar: true
#hasVerticalScrollBar: true
#miniScrollerHorizontal: true
#isMultiSelect: true
#valueChangeSelector: #selectionChangedByClick
#useIndex: true
#sequenceList: #browserNameList
#doubleClickChannel: #doubleClickChannel
#properties:
#(#PropertyListDictionary
#dragArgument: nil
#dropArgument: nil
#canDropSelector: #canDropContext:
#dropSelector: #doDropContext:
)
)
)
)
)
! !
!MethodList 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)."
^ #(
"/ #classHolder
#(#doubleClickChannel #action )
#forceGeneratorTrigger
#immediateUpdate
#inGeneratorHolder
#menuHolder
#methodCategoryHolder
#packageFilter
#selectedMethods
#selectionChangeCondition
#updateTrigger
#variableFilter
#filterClassVars
#showMethodInheritance
#showMethodComplexity
#showMethodTypeIcon
#showImageResourceMethodsImages
#sortBy
#showCoverageInformation
).
"Modified: / 27-04-2010 / 16:13:57 / cg"
! !
!MethodList methodsFor:'aspects'!
browserNameList
browserNameList isNil ifTrue:[
browserNameList := List new.
].
^ browserNameList.
"Modified: / 31.1.2000 / 00:42:44 / cg"
"Created: / 5.2.2000 / 22:38:32 / cg"
!
defaultSlaveModeValue
^ false.
!
filterClassVars
filterClassVars isNil ifTrue:[
filterClassVars := false asValue.
filterClassVars addDependent:self
].
^ filterClassVars
!
filterClassVars:aValueHolder
filterClassVars notNil ifTrue:[
filterClassVars removeDependent:self
].
filterClassVars := aValueHolder.
filterClassVars notNil ifTrue:[
filterClassVars addDependent:self
].
!
methodLabelHolder
^ self pseudoListLabelHolder
"Created: / 1.3.2000 / 20:50:07 / cg"
!
methodList
^ methodList
!
selectedMethodNameIndices
selectedMethodNameIndices isNil ifTrue:[
selectedMethodNameIndices := ValueHolder new.
selectedMethodNameIndices addDependent:self
].
^ selectedMethodNameIndices.
"Modified: / 5.2.2000 / 00:31:48 / cg"
"Created: / 5.2.2000 / 22:59:31 / cg"
!
selectedMethods
^ self selectionHolder
!
selectedMethods:aValueHolder
^ self selectionHolder:aValueHolder
!
showCoverageInformation
showCoverageInformation isNil ifTrue:[
showCoverageInformation := false asValue.
showCoverageInformation addDependent:self
].
^ showCoverageInformation
"Created: / 27-04-2010 / 16:13:28 / cg"
!
showCoverageInformation:aValueHolder
showCoverageInformation notNil ifTrue:[
showCoverageInformation removeDependent:self
].
showCoverageInformation := aValueHolder.
showCoverageInformation notNil ifTrue:[
showCoverageInformation addDependent:self
].
"Created: / 27-04-2010 / 16:13:35 / cg"
!
showImageResourceMethodsImages
showImageResourceMethodsImages isNil ifTrue:[
showImageResourceMethodsImages := false asValue.
showImageResourceMethodsImages addDependent:self
].
^ showImageResourceMethodsImages
!
showImageResourceMethodsImages:aValueHolder
showImageResourceMethodsImages notNil ifTrue:[
showImageResourceMethodsImages removeDependent:self
].
showImageResourceMethodsImages := aValueHolder.
showImageResourceMethodsImages notNil ifTrue:[
showImageResourceMethodsImages addDependent:self
].
!
showMethodComplexity
showMethodComplexity isNil ifTrue:[
showMethodComplexity := false asValue.
showMethodComplexity addDependent:self
].
^ showMethodComplexity
!
showMethodComplexity:aValueHolder
showMethodComplexity notNil ifTrue:[
showMethodComplexity removeDependent:self
].
showMethodComplexity := aValueHolder.
showMethodComplexity notNil ifTrue:[
showMethodComplexity addDependent:self
].
!
showMethodInheritance
showMethodInheritance isNil ifTrue:[
showMethodInheritance := false asValue.
showMethodInheritance addDependent:self
].
^ showMethodInheritance
!
showMethodInheritance:aValueHolder
showMethodInheritance notNil ifTrue:[
showMethodInheritance removeDependent:self
].
showMethodInheritance := aValueHolder.
showMethodInheritance notNil ifTrue:[
showMethodInheritance addDependent:self
].
!
showMethodTypeIcon
showMethodTypeIcon isNil ifTrue:[
showMethodTypeIcon := true asValue.
showMethodTypeIcon addDependent:self
].
^ showMethodTypeIcon
!
showMethodTypeIcon:aValueHolder
showMethodTypeIcon notNil ifTrue:[
showMethodTypeIcon removeDependent:self
].
showMethodTypeIcon := aValueHolder.
showMethodTypeIcon notNil ifTrue:[
showMethodTypeIcon addDependent:self
].
!
variableFilter
variableFilter isNil ifTrue:[
variableFilter := nil asValue.
variableFilter addDependent:self
].
^ variableFilter
!
variableFilter:aValueHolder
variableFilter notNil ifTrue:[
variableFilter removeDependent:self
].
variableFilter := aValueHolder.
variableFilter notNil ifTrue:[
variableFilter addDependent:self
].
! !
!MethodList methodsFor:'change & update'!
delayedUpdate:something with:aParameter from:changedObject
|cls sel oldMethod newMethod methods newSelection
selectionHolder selection needSelectionChange|
selectionHolder := self selectedMethods.
selection := selectionHolder value.
changedObject == Smalltalk ifTrue:[
classes notNil ifTrue:[
something == #methodCategory ifTrue:[
"/ ignore here - methodCategoryList will tell me if required
^ self
].
(something == #classOrganization
or:[ something == #methodCategoryAdded
or:[ something == #methodCategoryRemoved
or:[ something == #methodCategoriesRemoved
or:[ something == #methodCategoryRenamed ]]]]) ifTrue:[
"/ ignore here - methodCategoryList will tell me if required
^ self
].
something == #methodInClass ifTrue:[
"/ a method has been added/changed
cls := aParameter at:1.
(classes includesIdentical:cls) ifTrue:[
sel := aParameter at:2.
oldMethod := aParameter at:3.
newMethod := cls compiledMethodAt:sel.
(oldMethod notNil and:[newMethod notNil]) ifTrue:[
"a method was changed & acccepted;
No need for a rescan of the methodDictionary;
however, ensure that the refs to the old method are updated
"
methods := selection.
methods size > 0 ifTrue:[
(methods includesIdentical:oldMethod) ifTrue:[
needSelectionChange := true.
]
].
methodList replaceAllIdentical:oldMethod with:newMethod.
lastSelectedMethods notNil ifTrue:[
lastSelectedMethods replaceAllIdentical:oldMethod with:newMethod
].
methods size > 0 ifTrue:[
methods := methods asOrderedCollection.
methods replaceAllIdentical:oldMethod with:newMethod.
].
needSelectionChange == true ifTrue:[
selectionHolder setValue:methods.
"/ self enqueueDelayedMethodsSelectionChanged.
"/ need this to inform my browser that method was changed
"/ by someone else.
selectionHolder changed.
].
(variableFilter value size > 0
or:[oldMethod package ~= newMethod package
or:[oldMethod resources ~= newMethod resources
or:[showMethodComplexity value == true]]]) ifTrue:[
"/ only update that methods entry
self updateListEntryFor:newMethod.
"/ 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.
].
^ self.
].
something == #methodInClassRemoved ifTrue:[
cls := aParameter at:1.
(classes includesIdentical:cls) ifTrue:[
sel := aParameter at:2.
"/ method was removed - update the methodList
"/ Q: is this needed (methodCategoryList should send me a new inGenerator)
self invalidateList.
].
^ self.
].
(something == #methodTrap
or:[ something == #privacyOfMethod ]) ifTrue:[
cls := aParameter at:1.
sel := aParameter at:2.
(classes includesIdentical:cls) ifFalse:[ ^ self].
newMethod := cls compiledMethodAt:sel.
newMethod isNil ifTrue:[
self invalidateList.
^ self
].
(something == #privacyOfMethod) ifTrue:[
self updateListEntryFor:newMethod.
].
(something == #methodTrap) ifTrue:[
newMethod isWrapped ifTrue:[
oldMethod := newMethod originalMethod
] ifFalse:[
selection size > 0 ifTrue:[
oldMethod := selection detect:[:each | each isWrapped and:[each originalMethod == newMethod]] ifNone:nil.
]
].
selection size > 0 ifTrue:[
(selection includesIdentical:oldMethod) ifTrue:[
needSelectionChange := true.
]
].
methodList replaceAllIdentical:oldMethod with:newMethod.
lastSelectedMethods notNil ifTrue:[
lastSelectedMethods replaceAllIdentical:oldMethod with:newMethod
].
selection size > 0 ifTrue:[
selection := selection asOrderedCollection.
selection replaceAllIdentical:oldMethod with:newMethod.
].
needSelectionChange == true ifTrue:[
selectionHolder changed.
].
"/ actually, could just change that single item ...
"/ ... might be cheaper, if list is huge.
"/ only update that methods entry
self updateListEntryFor:newMethod.
"/ self invalidateList.
].
^ self
].
(something == #projectOrganization
or:[something == #lastTestRunResult]) ifTrue:[
aParameter notNil ifTrue:[
cls := aParameter at:1.
cls notNil ifTrue:[
((classes includesIdentical:cls theNonMetaclass)
or:[(classes includesIdentical:cls theMetaclass)]) ifTrue:[
self invalidateList.
].
].
] ifFalse:[
self invalidateList.
].
^ self
].
"/ everything else is ignored
"/ self halt.
].
^ self
].
"/ something == #organization ifTrue:[
"/self halt:'no longer'.
"/^ self.
"/ "/ a methods cateory has changed
"/ (classes includesIdentical:changedObject) ifTrue:[
"/ aParameter isSymbol ifTrue:[
"/ "/ a method with a new category
"/ (self methodList includesIdentical:(changedObject compiledMethodAt:aParameter)) ifTrue:[
"/ self invalidateList.
"/ ].
"/ ^ self.
"/ ].
"/ "/ a new category (no method yet)
"/ self invalidateList
"/ ].
"/ ^ self
"/ ].
"/ something == #methodDictionary ifTrue:[
"/self halt:'no longer'.
"/^ self.
"/ "/ a method has been added/removed
"/ (classes includesIdentical:changedObject) ifTrue:[
"/ aParameter isArray ifTrue:[
"/ sel := aParameter at:1.
"/ oldMethod := aParameter at:2.
"/ newMethod := changedObject compiledMethodAt:sel.
"/ oldMethod notNil ifTrue:[
"/ "a method was changed & acccepted;
"/ No need for a rescan of the methodDictionary;
"/ however, ensure that the refs to the old method are updated
"/ "
"/ methods := selection.
"/ methods size > 0 ifTrue:[
"/ (methods includesIdentical:oldMethod) ifTrue:[
"/ needSelectionChange := true.
"/ ]
"/ ].
"/ methodList replaceAllIdentical:oldMethod with:newMethod.
"/ lastSelectedMethods notNil ifTrue:[
"/ lastSelectedMethods replaceAllIdentical:oldMethod with:newMethod
"/ ].
"/ methods size > 0 ifTrue:[
"/ methods := methods asOrderedCollection.
"/ methods replaceAllIdentical:oldMethod with:newMethod.
"/ ].
"/ needSelectionChange == true ifTrue:[
"/ selectionHolder setValue:methods.
"/ selectionHolder changed.
"/ ].
"/ ^ self.
"/ ]
"/ ].
"/ "/ class has changed must update the methodList
"/ self invalidateList.
"/ ].
"/ ^ self.
"/ ].
"/ something == #projectOrganization ifTrue:[
"/ ((classes includesIdentical:changedObject theNonMetaclass)
"/ or:[(classes includesIdentical:changedObject theMetaclass)]) ifTrue:[
"/ self invalidateList.
"/ ].
"/ ^ self
"/ ].
changedObject == sortBy ifTrue:[
listValid ~~ true ifTrue:[ "/ could be nil
inGeneratorHolder value isNil ifTrue:[
"/ ok, no need to react on that one
"/ (will invalidate anyway, once I have more info at hand)
^ self
].
].
self invalidateList.
^ self
].
(changedObject == variableFilter
or:[changedObject == filterClassVars
or:[changedObject == showMethodInheritance
or:[changedObject == showMethodComplexity]]]) ifTrue:[
self invalidateList.
^ self
].
changedObject == selectedMethodNameIndices ifTrue:[
newSelection := self selectedMethodNameIndices value collect:[:idx | methodList at:idx].
newSelection ~= selection ifTrue:[
selectionHolder value:newSelection.
lastSelectedMethods := newSelection.
lastSelectedMethods notNil ifTrue:[
lastSelectedMethods := lastSelectedMethods asOrderedCollection
].
] ifFalse:[
"/ a reselect - force update
"/ selection size == 1 ifTrue:[
selectionHolder setValue:newSelection.
selectionHolder changed:#value.
"/ ].
].
^ self
].
changedObject == selectionHolder ifTrue:[
self selectedMethodsChanged.
lastSelectedMethods := selectionHolder value.
lastSelectedMethods notNil ifTrue:[
lastSelectedMethods := lastSelectedMethods asOrderedCollection
].
^ self
].
"/ something == #methodTrap ifTrue:[
"/self halt:'no longer'.
"/^ self.
"/ (classes includesIdentical:changedObject) ifTrue:[
"/ newMethod := changedObject compiledMethodAt:aParameter.
"/ newMethod isNil ifTrue:[
"/ self invalidateList.
"/ ^ self
"/ ].
"/ newMethod isWrapped ifTrue:[
"/ oldMethod := newMethod originalMethod
"/ ] ifFalse:[
"/ selection size > 0 ifTrue:[
"/ oldMethod := selection detect:[:each | each isWrapped and:[each originalMethod == newMethod]] ifNone:nil.
"/ ]
"/ ].
"/
"/ selection size > 0 ifTrue:[
"/ (selection includesIdentical:oldMethod) ifTrue:[
"/ needSelectionChange := true.
"/ ]
"/ ].
"/"/ methodList replaceAllIdentical:oldMethod with:newMethod.
"/ lastSelectedMethods notNil ifTrue:[
"/ lastSelectedMethods replaceAllIdentical:oldMethod with:newMethod
"/ ].
"/ selection size > 0 ifTrue:[
"/ selection := selection asOrderedCollection.
"/ selection replaceAllIdentical:oldMethod with:newMethod.
"/ ].
"/ needSelectionChange == true ifTrue:[
"/ selectionHolder changed.
"/ ].
"/ self invalidateList.
"/ ^ self
"/ ].
"/ ^ self
"/ ].
super delayedUpdate:something with:aParameter from:changedObject
"Created: / 05-02-2000 / 13:42:14 / cg"
"Modified: / 06-08-2006 / 10:36:49 / cg"
!
selectedMethodsChanged
"the set of selected methods has changed;
update the selection-index collection (for the selectionInListView)"
|indices methods reverseMap
selectedMethodsHolder selectedMethods selectedMethodNameIndicesHolder|
methods := methodList ? #().
methods size == 0 ifTrue:[
"/ this may happen during early startup,
"/ when invoked with a preset methodSelection,
"/ and the methodGenerator has not yet been setup
"/ to not clobber the selection, defer the update
"/ until the methodList arrives ...
^ self
].
selectedMethodsHolder := self selectedMethods.
selectedMethods := selectedMethodsHolder value.
"/ check if all is selected (likely)
((selectedMethods size == methodList size)
and:[selectedMethods = methodList]) ifTrue:[
indices := (1 to:selectedMethods size)
] ifFalse:[
selectedMethods size > 100 ifTrue:[
"/ check if all is selected (likely)
((selectedMethods size == methodList size)
and:[selectedMethods = methodList]) ifTrue:[
indices := (1 to:selectedMethods size)
] ifFalse:[
"/ for big collections, generate a reverse map
reverseMap := IdentityDictionary new.
methods keysAndValuesDo:[:idx :mthd | reverseMap at:mthd put:idx].
indices := selectedMethods collect:[:eachSelectedMethod |
reverseMap at:eachSelectedMethod ifAbsent:0
]
]
] ifFalse:[
indices := (selectedMethods ? #()) collect:[:eachSelectedMethod |
methods identityIndexOf:eachSelectedMethod.
]
].
indices := indices select:[:idx | idx ~= 0].
].
selectedMethodNameIndicesHolder := self selectedMethodNameIndices.
selectedMethodNameIndicesHolder value ~= indices ifTrue:[
selectedMethodNameIndicesHolder value:indices.
]
!
selectionChanged
|methods|
methods := ((self selectedMethodNameIndices value) ? #()) collect:[:idx | methodList at:idx].
methods notEmpty ifTrue:[
lastSelectedMethods := methods asOrderedCollection.
].
"/ to allow reselect, change my valueHolder, even if the same collection
"/ self selectedMethods value ~= methods ifTrue:[
self selectedMethods value:methods
"/ ]
"Created: / 5.2.2000 / 13:42:14 / cg"
"Modified: / 5.2.2000 / 23:32:20 / cg"
!
selectionChangedByClick
"we are not interested in that - get another notification
via the changed valueHolder"
!
update:something with:aParameter from:changedObject
|cls|
"/ some can be ignored immediately
changedObject == Smalltalk ifTrue:[
classes isNil ifTrue:[
^ self.
].
something isNil ifTrue:[
"/ self halt "/ huh - Smalltalk changed - so what ?
^ self.
].
something == #classComment ifTrue:[
^ self.
].
something == #classVariables ifTrue:[
^ self.
].
something == #organization ifTrue:[
^ self.
].
something == #methodCategory ifTrue:[
"/ ignore here - methodCategoryList will tell me if required
^ self
].
(something == #classOrganization
or:[ something == #methodCategoryAdded
or:[ something == #methodCategoryRemoved
or:[ something == #methodCategoriesRemoved
or:[ something == #methodCategoryRenamed ]]]]) ifTrue:[
"/ ignore here - methodCategoryList will tell me if required
^ self
].
(something == #methodTrap
or:[ something == #methodPrivacy
or:[ something == #lastTestRunResult] ]) ifTrue:[
self window shown ifFalse:[
changedObject removeDependent:self. "/ ?????
^ self
].
cls := aParameter at:1.
(classes includesIdentical:cls) ifFalse:[
^ self "/ I dont care for that class
].
].
"/ as the organisation changes, flush my remembered redefinition-cache-info
classAndSelectorsRedefinedBySubclassesOfClass := nil.
something == #classDefinition ifTrue:[
cls := aParameter.
(classes contains:[:aClass | aClass name == cls name]) ifFalse:[
^ self "/ I dont care for that class
].
classes := classes collect:[:eachClass | eachClass isMeta ifTrue:[
(Smalltalk at:eachClass theNonMetaclass name) class
] ifFalse:[
Smalltalk at:eachClass name
]
].
self updateList.
^ self.
].
something == #newClass ifTrue:[
^ self.
].
something == #classRemove ifTrue:[
^ self.
].
something == #classRename ifTrue:[
^ self.
].
].
"/ these must lead to immediate update of the selectedMethods collection
"/ (otherwise, that collection might be updated too late, leading to
"/ an obsolete methods code being shown by the codeView.
something == #methodInClass ifTrue:[
"/ as the organisation changes, flush my remembered redefinition-cache-info
classAndSelectorsRedefinedBySubclassesOfClass := nil.
cls := aParameter at:1.
(classes includesIdentical:cls) ifFalse:[
^ self "/ I dont care for that class
].
self enqueueDelayedUpdate:something with:aParameter from:changedObject.
^ self
].
something == #methodInClassRemoved ifTrue:[
cls := aParameter at:1.
(classes includesIdentical:cls) ifFalse:[
^ self "/ I dont care for that class
].
].
super update:something with:aParameter from:changedObject
"Modified: / 05-03-2007 / 16:08:28 / cg"
! !
!MethodList methodsFor:'drag & drop'!
canDropContext:aDropContext
|methods|
aDropContext sourceWidget == aDropContext targetWidget ifTrue:[^ false].
methods := aDropContext dropObjects collect:[:obj | obj theObject].
(methods conform:[:aMethod | aMethod isMethod]) ifFalse:[^ false].
self masterApplication theSingleSelectedClass isNil ifTrue:[^ false].
^ true
"Modified: / 13-09-2006 / 11:43:54 / cg"
!
doDropContext:aDropContext
|methods browser|
methods := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
(methods conform:[:something | something isMethod]) ifFalse:[^ self].
browser := self masterApplication.
aDropContext dragType == DropContext dragTypeCopy ifTrue:[
browser
copyMethods:methods
toClass:(browser theSingleSelectedClass).
] ifFalse:[
browser
moveMethods:methods
toClass:(browser theSingleSelectedClass).
].
"Modified: / 13-09-2006 / 11:43:44 / cg"
! !
!MethodList methodsFor:'private'!
listOfMethodNames
|methods entries selectorBag newNameList
allClasses newClasses allCategories "allSelectors" generator
doShowClass doShowClassFirst doShowCategory
enforceClassAndProtocolInList theMethod sortByClass anyMethodToWatch mclass|
generator := inGeneratorHolder value.
generator isNil ifTrue:[^ #() ].
allClasses := IdentitySet new.
allCategories := IdentitySet new. "/ not needed - all I need to know is if there is more than 1 category
"/ allSelectors := Set new.
newClasses := IdentitySet new.
selectorBag := Bag new.
entries := OrderedCollection new.
enforceClassAndProtocolInList := false.
anyMethodToWatch := false.
"/ generator generates nil-selector entries
"/ to pass multiple-class and multiple-protocol info
generator do:[:cls :cat :sel :mthd |
(cls isNil and:[cat isNil and:[sel isNil]])
ifTrue:[
enforceClassAndProtocolInList := true
] ifFalse:[
cls notNil ifTrue:[
allClasses add:cls.
].
cat notNil ifTrue:[
allCategories add:cat.
].
sel notNil ifTrue:[
entries add:(Array with:cls with:sel with:mthd).
selectorBag add:sel.
newClasses add:cls.
"/ allSelectors add:sel.
]
].
(mthd notNil and:[mthd isWrapped]) ifTrue:[
(mthd isTiming
or:[mthd isCounting
or:[mthd isCountingMemoryUsage]])
ifTrue:[
anyMethodToWatch := true
]
].
].
showMethodInheritance value ~~ false ifTrue:[
"/ collect redefinition information once (big speedup for #methodIsRedefinedbelow)
classAndSelectorsRedefinedBySubclassesOfClass isNil ifTrue:[
classAndSelectorsRedefinedBySubclassesOfClass := IdentityDictionary new.
].
allClasses do:[:cls | |d|
d := classAndSelectorsRedefinedBySubclassesOfClass.
(d notNil and:[ (d includesKey:cls) not ]) ifTrue:[
cls isLoaded ifTrue:[
d at:cls put:(self setOfAllSelectorsImplementedBelow:cls)
]
]
].
].
"/ multiple classes must: add the className for some
doShowClass := enforceClassAndProtocolInList or:[allClasses size > 1].
"/ multiple categories: must add the categorie for some
doShowCategory := enforceClassAndProtocolInList or:[allCategories size > 1].
doShowClassFirst := doShowClass. "/ (doShowClass and:[allSelectors size == 1]).
doShowClassFirst := doShowClass and:[ sortBy value == #class ].
sortBy value == false ifTrue:[
"/ do not sort
] ifFalse:[
(doShowClass not and:[ sortBy value == #class ]) ifTrue:[
"/ multiple classes must add the className for some
"/ check, if doShowClass must be enforced
entries do:[:entry |
|cls sel mthd s needClass|
cls := entry at:1.
sel := entry at:2.
mthd := entry at:3.
doShowClass ifFalse:[
doShowClass := (selectorBag occurrencesOf:sel) > 1
].
].
].
sortByClass := doShowClass and:[ sortBy value == #class ].
sortByClass ifTrue:[
entries sort:[:a :b | |nmA nmB clsNmA clsNmB|
clsNmA := (a at:1) name.
clsNmB := (b at:1) name.
clsNmA = clsNmB ifTrue:[
nmA := (a at:2).
nmB := (b at:2).
nmA < nmB
] ifFalse:[
clsNmA < clsNmB
]
].
] ifFalse:[
sortBy value == #category ifTrue:[
entries sort:[:a :b | |nmA nmB catA catB clsNmA clsNmB|
catA := (a at:3) category.
catB := (b at:3) category.
catA = catB ifTrue:[
nmA := (a at:2).
nmB := (b at:2).
nmA = nmB ifTrue:[
clsNmA := (a at:1) name.
clsNmB := (b at:1) name.
clsNmA < clsNmB
] ifFalse:[
nmA < nmB
]
] ifFalse:[
catA < catB
]
].
] ifFalse:[
entries sort:[:a :b | |nmA nmB clsNmA clsNmB|
nmA := (a at:2).
nmB := (b at:2).
nmA = nmB ifTrue:[
clsNmA := (a at:1) name.
clsNmB := (b at:1) name.
clsNmA < clsNmB
] ifFalse:[
nmA < nmB
]
].
].
].
].
methods := OrderedCollection new:(entries size).
"/ first generate the new methodList, and see if it is different ...
entries do:[:entry |
|sel mthd|
mthd := entry at:3.
methods add:mthd.
].
false "methodList = methods" "does not care for changed icons" ifTrue:[
"/ same list
newNameList := self browserNameList.
] ifFalse:[
newNameList := OrderedCollection new:(entries size).
"/ multiple classes must add the className for some
entries do:[:entry |
|cls sel mthd s needClass|
cls := entry at:1.
sel := entry at:2.
mthd := entry at:3.
needClass := doShowClass.
"/ needClass ifFalse:[
"/ needClass := (selectorBag occurrencesOf:sel) > 1
"/ ].
s := self
listEntryForMethod:mthd
selector:sel
class:cls
showClass:needClass
showCategory:doShowCategory
classFirst:doShowClassFirst.
"/ s := mthd printStringForBrowserWithSelector:sel inClass:cls.
"/ needClass ifTrue:[
"/ s := s , ' [' , cls name , ']'.
"/ ].
"/ doShowCategory ifTrue:[
"/ s := s , ' {' , mthd category "asText allItalic" , '}'
"/ ].
newNameList add:s.
].
].
self makeIndependent.
classes := newClasses.
self makeDependent.
methodList := methods.
methods size == 1 ifTrue:[
theMethod := methods first.
mclass := theMethod mclass.
mclass isNil ifTrue:[
theMethod isWrapped ifTrue:[
theMethod := theMethod originalMethod.
mclass := theMethod mclass.
].
].
self methodLabelHolder value:(
mclass isNil
ifTrue:[('???' , ' ' , '???')]
ifFalse:[(mclass name , ' ' , theMethod selector)])
].
anyMethodToWatch ifTrue:[
self startWatchProcess.
] ifFalse:[
self stopWatchProcess.
].
"/ remember these, in case of an incremental (single method only)
"/ update in the future.
lastShowClass := doShowClass.
lastShowClassFirst := doShowClassFirst.
lastShowCategory := doShowCategory.
^ newNameList.
"Created: / 05-02-2000 / 22:43:40 / cg"
"Modified: / 26-01-2007 / 14:58:59 / cg"
!
makeDependent
Smalltalk addDependent:self.
"/ ChangeSet addDependent:self.
"Modified: / 10-11-2006 / 17:57:01 / cg"
!
makeIndependent
Smalltalk removeDependent:self.
"/ ChangeSet removeDependent:self.
!
method:mthd includesModsOfClassVariable:variablesToHighLight
^ self method:mthd includesRefsToVariable:variablesToHighLight askParserWith:#modifiedClassVars
!
method:mthd includesModsOfInstanceVariable:variablesToHighLight
^ self method:mthd includesRefsToVariable:variablesToHighLight askParserWith:#modifiedInstVars
!
method:mthd includesRefsToClassVariable:variablesToHighLight
^ self method:mthd includesRefsToVariable:variablesToHighLight askParserWith:#usedClassVars
!
method:mthd includesRefsToInstanceVariable:variablesToHighLight
^ self method:mthd includesRefsToVariable:variablesToHighLight askParserWith:#usedInstVars
!
method:mthd includesRefsToVariable:variablesToHighLight askParserWith:querySelector
|cls src parser usedVars anyVarNameAccessable|
cls := mthd mclass.
cls isNil ifTrue:[^ false].
anyVarNameAccessable := cls allInstVarNames includesAny:variablesToHighLight.
anyVarNameAccessable ifFalse:[
anyVarNameAccessable := cls theNonMetaclass allClassVarNames includesAny:variablesToHighLight.
].
anyVarNameAccessable ifFalse:[
"/ no need to parse
^ false
].
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
]
]
]
].
^ false
!
methodIsInheritedFromAbove:aMethod
|mClass|
mClass := aMethod mclass.
(mClass notNil and:[mClass superclass notNil]) ifTrue:[
^ (mClass superclass whichClassIncludesSelector:aMethod selector) notNil.
].
^ false
!
methodIsRedefinedBelow:aMethod
|mclass subClasses setOfRedefinedSelectors|
mclass := aMethod mclass.
mclass isNil ifTrue:[^ false].
"/ if possible, make use of info prepared by listOfMethodNames
classAndSelectorsRedefinedBySubclassesOfClass notNil
ifTrue:[
setOfRedefinedSelectors := classAndSelectorsRedefinedBySubclassesOfClass at:mclass ifAbsent:nil.
setOfRedefinedSelectors notNil ifTrue:[
^ setOfRedefinedSelectors includes:aMethod selector
]
].
lastMethodClass == mclass ifTrue:[
subClasses := lastMethodClassesSubclasses
] ifFalse:[
subClasses := aMethod mclass allSubclasses.
lastMethodClassesSubclasses := subClasses.
lastMethodClass := mclass.
].
^ subClasses contains:[:cls | cls includesSelector:aMethod selector].
!
redefinedOrInheritedIconFor:aMethod
|inherited redefined subclassResponsibility|
inherited := self methodIsInheritedFromAbove:aMethod.
redefined := self methodIsRedefinedBelow:aMethod.
inherited ifTrue:[
redefined ifTrue:[
^ self methodInheritedFromAboveAndRedefinedBelowIcon.
].
^ self methodInheritedFromAboveIcon.
].
subclassResponsibility := aMethod sends:#subclassResponsibility.
redefined ifTrue:[
subclassResponsibility ifTrue:[
^ self methodIsSubclassResponsibilityAndRedefinedBelowIcon.
].
^ self methodRedefinedBelowIcon.
].
subclassResponsibility ifTrue:[
^ self methodIsSubclassResponsibilityIcon.
].
^ self methodEmptyInheritedIcon
!
release
super release.
filterClassVars removeDependent:self.
selectedMethodNameIndices removeDependent:self.
showMethodInheritance removeDependent:self.
variableFilter removeDependent:self.
!
resourceIconForMethod:aMethod
^ SystemBrowser resourceIconForMethod:aMethod
"Modified: / 17-08-2006 / 09:09:01 / cg"
!
setOfAllSelectorsImplementedBelow:aClass
|set|
set := IdentitySet new.
aClass allSubclassesDo:[:eachSubclass |
set addAll:(eachSubclass methodDictionary keys).
].
^ set
!
updateList
|prevSelection newList newSelection newSelIdx reverseMap sameContents newListSize oldListSize
prevClasses methodSet selectedMethodsHolder|
selectedMethodsHolder := self selectedMethods.
prevSelection := selectedMethodsHolder value ? #().
prevClasses := classes ifNil:[ #() ] ifNotNil:[ classes copy ].
oldListSize := self browserNameList size.
self topApplication withWaitCursorDo:[
newList := self listOfMethodNames.
].
newListSize := newList size.
sameContents := self updateListFor:newList.
sameContents ifFalse:[
"/ self browserNameList value:newList.
(prevSelection size == 0
and:[selectedMethodsHolder value size ~~ 0]) ifTrue:[
"/ this happens during early startup time,
"/ when the selection is already (pre-)set,
"/ and the methodList is generated the first time
"/ (i.e. when opened with preset selection
"/ do not clobber the selection in this case.
prevSelection := selectedMethodsHolder value.
].
(methodList size == 0 or:[prevSelection size == 0]) ifTrue:[
newSelection := #()
] ifFalse:[
methodSet := methodList.
"/ inclusion test is much faster with sets, if the number of items is large
methodList size > 30 ifTrue:[
"/ however, only if its worth building the set ...
prevSelection size > 5 ifTrue:[
methodSet := methodSet asIdentitySet.
]
].
newSelection := prevSelection select:[:item | methodSet includesIdentical:item].
].
newSelection size > 0 ifTrue:[
newSelection size > 100 ifTrue:[
"/ need selection indices - might be expensive if done straight forward...
reverseMap := IdentityDictionary new.
methodList keysAndValuesDo:[:idx :mthd | reverseMap at:mthd put:idx].
newSelIdx := newSelection collect:[:mthd | reverseMap at:mthd].
] ifFalse:[
newSelIdx := newSelection collect:[:mthd | methodList identityIndexOf:mthd]
].
"/ self halt.
"/ force change (for dependents)
newSelIdx ~= selectedMethodNameIndices value ifTrue:[
selectedMethodNameIndices value:newSelIdx.
].
] ifFalse:[
lastSelectedMethods := selectedMethodsHolder value.
lastSelectedMethods notNil ifTrue:[
lastSelectedMethods := lastSelectedMethods asOrderedCollection
].
selectedMethodNameIndices value size > 0 ifTrue:[
selectedMethodNameIndices value:#().
]
].
newSelection ~= prevSelection ifTrue:[
self selectionChanged.
]
] 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:[
(newListSize > 0 or:[oldListSize > 0]) ifTrue:[
self selectionChanged.
]
]
]
"/ ].
"Modified: / 05-03-2007 / 16:07:24 / cg"
!
updateListEntryFor:aMethod
"update my list for a single method.
(used when a single methods package, code or whatever changes, and a full udpate
would be too slow)"
|s idx|
s := self
listEntryForMethod:aMethod
selector:aMethod selector
class:aMethod mclass
showClass:lastShowClass
showCategory:lastShowCategory
classFirst:lastShowClassFirst.
idx := methodList identityIndexOf:aMethod.
idx == 0 ifTrue:[
aMethod isWrapped ifTrue:[
idx := methodList identityIndexOf:aMethod originalMethod.
]
].
idx == 0 ifTrue:[
self invalidateList
] ifFalse:[
self browserNameList at:idx put:s.
]
! !
!MethodList methodsFor:'private-presentation'!
colorForCoverageInformationOfMethod:aMethod
aMethod isInstrumented ifFalse:[^ nil].
aMethod category = 'documentation' ifTrue:[^ nil].
aMethod hasBeenCalled ifTrue:[
aMethod haveAllBlocksBeenExecuted ifTrue:[
^ UserPreferences current colorForInstrumentedFullyCoveredCode
].
^ UserPreferences current colorForInstrumentedPartiallyCoveredCode
].
^ UserPreferences current colorForInstrumentedNeverCalledCode
"Created: / 30-04-2010 / 11:53:38 / cg"
!
listEntryForMethod:aMethod selector:selector class:cls showClass:showClass showCategory:showCategory classFirst:showClassFirst
"answer a method list entry
gimmics:
adding a little image to breakPointed methods,
inheritance indicators,
highlight accessors of variable"
|clsName s icn variablesToHighlight classVarsToHighLight
doHighLight doHighLightRed clr emp cat l redefIcon
metrics complexity complexityString complexityIcon mark|
aMethod isNil ifTrue:[
"/ a non-existing (pseudo) method (such as required protocol)
^ selector colorizeAllWith:Color red.
].
aMethod isAssociation ifTrue:[
self halt:'should not happen'.
].
selector isNil ifTrue:[
s := '???'
] ifFalse:[
s := aMethod printStringForBrowserWithSelector:selector inClass:cls.
].
showClassFirst ifTrue:[
clsName := cls nameInBrowser.
s := clsName , ' ' , s allBold
].
"/
"/ wrap icons (i.e. break- or trace points)
"/ have higher prio ...
"/
(aMethod notNil and:[aMethod isWrapped]) ifTrue:[
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
aMethod isBreakpointed ifTrue:[
icn := self stopIcon
] ifFalse:[
aMethod isTimed ifTrue:[
icn := self timeIcon
] ifFalse:[
icn := self traceIcon
]
].
].
icn isNil ifTrue:[
self showImageResourceMethodsImages value ~~ false ifTrue:[
(aMethod hasImageResource) ifTrue:[
aMethod mclass isMeta ifTrue:[
icn := aMethod valueWithReceiver:nil arguments:nil .
].
].
].
].
icn isNil ifTrue:[
showMethodTypeIcon value ~~ false ifTrue:[
icn := self resourceIconForMethod:aMethod.
].
icn isNil ifTrue:[
aMethod isProtected ifTrue:[
icn := self protectedMethodIcon
] ifFalse:[
aMethod isPrivate ifTrue:[
icn := self privateMethodIcon
] ifFalse:[
(aMethod isIgnored) ifTrue:[
icn := self ignoredMethodIcon
] ifFalse:[
(aMethod isJavaMethod and:[aMethod isAbstract]) ifTrue:[
icn := self abstractMethodIcon
]
]
]
].
].
].
icn isNil ifTrue:[
(selector startsWith:'test') ifTrue:[
(cls isTestCaseLike and:[cls isAbstract not]) ifTrue:[
cls lastTestRunResultOrNil == false ifTrue:[
(cls testSelectorFailed:selector) ifTrue:[
icn := SystemBrowser testCaseFailedIcon
] ifFalse:[
"/ icn := SystemBrowser testCasePassedIcon
].
]
].
]
].
showClass ifTrue:[
showClassFirst ifFalse:[
s := s , ' [' , cls name allBold , ']'.
]
].
showCategory ifTrue:[
cat := aMethod category.
cat notNil ifTrue:[
s := s , ' {' , cat "asText allItalic" , '}'
]
].
self showCoverageInformation value ifTrue:[
clr := self colorForCoverageInformationOfMethod:aMethod.
clr notNil ifTrue:[
s := self colorize:s with:(#color->clr).
"/ aMethod isInstrumented ifTrue:[
"/ icn := self instrumentationIcon
"/ ].
].
] ifFalse:[
(ChangeSet current includesChangeForClass:cls selector:selector) ifTrue:[
mark := self class markForBeingInChangeList.
"/ mark := self colorizeForChangedCode:mark.
s := s , mark.
"/ cg: I dont know why this was disabled - it is req'd to
"/ see changed methods in a method list (implementors...)
s := self colorizeForChangedCode:s.
].
(SmallTeam notNil and:[SmallTeam includesChangeForClass:cls selector:selector]) ifTrue:[
s := (self colorizeForChangedCodeInSmallTeam:'!! '),s
].
].
variablesToHighlight := variableFilter value.
variablesToHighlight size > 0 ifTrue:[
classVarsToHighLight := filterClassVars value.
classVarsToHighLight ifTrue:[
doHighLight := self method:aMethod includesRefsToClassVariable:variablesToHighlight.
doHighLight ifTrue:[
doHighLightRed := self method:aMethod includesModsOfClassVariable:variablesToHighlight.
].
] ifFalse:[
doHighLight := self method:aMethod includesRefsToInstanceVariable:variablesToHighlight.
doHighLight ifTrue:[
doHighLightRed := self method:aMethod includesModsOfInstanceVariable:variablesToHighlight
]
].
doHighLight ifTrue:[
s := s allBold.
doHighLightRed ifTrue:[
emp := (UserPreferences current emphasisForWrittenVariable)
] ifFalse:[
emp := (UserPreferences current emphasisForReadVariable)
].
s := s emphasisAllAdd:emp
]
].
(showMethodComplexity value == true
and:[ OOM::MethodMetrics notNil ]) ifTrue:[
icn isNil ifTrue:[
metrics := OOM::MethodMetrics forMethod:aMethod.
complexity := metrics complexity ? 0.
complexityIcon := OOM::MethodMetrics iconForComplexity:complexity.
ShowComplexityValue == true ifTrue:[
complexityString := '{' , complexity printString , '}'.
s := complexityString , ' ' , s.
].
"/ icn := icn ? complexityIcon.
s := LabelAndIcon icon:complexityIcon string:s.
].
].
showMethodInheritance value ~~ false ifTrue:[
redefIcon := self redefinedOrInheritedIconFor:aMethod.
].
(icn notNil or:[redefIcon notNil]) ifTrue:[
l := LabelAndIcon icon:redefIcon string:s.
l image:icn.
l gap:2.
^ l
].
^ s
"Created: / 22-10-1996 / 19:51:00 / cg"
"Modified: / 06-07-2011 / 14:05:25 / cg"
! !
!MethodList methodsFor:'private-watching'!
startWatchProcess
updateProcess notNil ifTrue:[
^ self
].
updateProcess := [
[true] whileTrue:[
Delay waitForSeconds:1.
self enqueueDelayedUpdateList
]
] fork.
!
stopWatchProcess
|p|
(p := updateProcess) notNil ifTrue:[
updateProcess := nil.
p terminate
].
! !
!MethodList methodsFor:'setup'!
postBuildWith:aBuilder
|methodListView|
super postBuildWith:aBuilder.
methodListView := aBuilder componentAt:'List'.
methodListView notNil ifTrue:[
methodListView allowDrag:true.
methodListView dragObjectConverter:[:obj |
|nm method idx|
nm := obj theObject asString string string.
idx := browserNameList value findFirst:[:item | item string string = nm].
method := methodList value at:idx.
DropObject newMethod:method.
].
]
! !
!MethodList class methodsFor:'documentation'!
version_CVS
^ '$Header: /cvs/stx/stx/libtool/Tools_MethodList.st,v 1.49 2011-07-06 12:19:35 cg Exp $'
! !