--- a/Tools_MethodCategoryList.st Mon Oct 26 17:19:40 2009 +0100
+++ b/Tools_MethodCategoryList.st Mon Oct 26 18:28:28 2009 +0100
@@ -29,7 +29,7 @@
instanceVariableNames:'flags'
classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented
FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension
- FlagIsRedefine FlagIsOverride'
+ FlagIsRedefine FlagIsOverride FlagIsSubclassResponsibility'
poolDictionaries:''
privateIn:MethodCategoryList
!
@@ -806,7 +806,7 @@
|protocols
allProtocols superSendProtocols uncommentedProtocols obsoleteProtocols
documentationProtocols longProtocols extensionProtocols redefinedProtocols overrideProtocols
- missingRequiredProtocols
+ missingRequiredProtocols subclassResponsibilities
noCat static notStatic classSelectorPairsAlreadyDone
packages remainingClasses remainingCategories classesAlreadyDone noPackage|
@@ -831,6 +831,7 @@
redefinedProtocols := protocols includes:(self class nameListEntryForRedefined).
overrideProtocols := protocols includes:(self class nameListEntryForOverride).
missingRequiredProtocols := protocols includes:(self class nameListEntryForRequired).
+ subclassResponsibilities := protocols includes:(self class nameListEntryForMustBeRedefinedInSubclass).
"/ packages := packageFilter value value.
"/ (packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
@@ -906,6 +907,10 @@
redefinedProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isRedefine ]].
+ includeIt ifFalse:[
+ subclassResponsibilities ifTrue:[
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
+ includeIt := info isSubclassResponsibility ]].
includeIt ifTrue:[
(methodVisibilityHolder value == #class) ifTrue:[
@@ -918,7 +923,7 @@
].
anyInThisClass := true.
remainingCategories remove:cat ifAbsent:nil.
- ]
+ ].
]
].
@@ -1050,8 +1055,9 @@
itemsInChangeSet itemsInRemoteChangeSet
packageFilterOnInput packageFilter nameListEntryForALL changeSet
emphasizedPlus emphasisForRef emphasisForMod
- numObsolete numSuper numUncommented numDocumentation numLong numOverride
- numRedefine numExtension numMissingRequired showPseudoProtocols|
+ numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride
+ numRedefine numExtension numMissingRequired numSubclassResponsibility showPseudoProtocols
+ addPseudoEntry|
generator := inGeneratorHolder value.
generator isNil ifTrue:[ ^ #() ].
@@ -1083,7 +1089,7 @@
variablesToHighlight := variableFilter value.
classVarsToHighLight := filterClassVars value.
numObsolete := numSuper := numUncommented := numDocumentation := numLong := 0.
- numRedefine := numOverride := numExtension := numMissingRequired := 0.
+ numRedefine := numOverride := numExtension := numMissingRequired := numSubclassResponsibility := 0.
generator do:[:clsIn :catIn |
|emptyProtocols clsName doHighLight doHighLightRed suppress|
@@ -1125,7 +1131,8 @@
].
]
]
- ].
+ ].
+
showPseudoProtocols value ifTrue:[
cls selectorsAndMethodsDo:[:sel :mthd |
|info|
@@ -1140,6 +1147,7 @@
info isExtensionMethod ifTrue:[ numExtension := numExtension + 1 ].
info isOverride ifTrue:[ numOverride := numOverride + 1 ].
info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
+ info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
]
].
].
@@ -1162,6 +1170,8 @@
]
].
+ numAll := 0.
+
changeSet := ChangeSet current.
classesProcessed do:[:eachClass |
@@ -1203,6 +1213,7 @@
required := CodeGeneratorTool missingRequiredProtocolFor:eachClass.
numMissingRequired := numMissingRequired + required size.
].
+ numAll := numAll + (eachClass methodDictionary size)
].
categoryList := categoryList asOrderedCollection.
@@ -1276,49 +1287,38 @@
].
self protocolLabelHolder value:nm
].
+
categoryList notEmpty ifTrue:[
noAllItem value ~~ true ifTrue:[
- categoryList addFirst:(nameListEntryForALL allItalic).
+ "/ categoryList addFirst:((self class nameListEntryForALLWithCount bindWith:numAll) allItalic colorizeAllWith:Color grey).
+ categoryList addFirst:(nameListEntryForALL allItalic colorizeAllWith:Color grey).
rawProtocolList addFirst:nameListEntryForALL.
].
].
showPseudoProtocols value ifTrue:[
- numSuper > 0 ifTrue:[
- categoryList add:((self class nameListEntryForSuperSend bindWith:numSuper) allItalic).
- rawProtocolList add:self class nameListEntryForSuperSend.
- ].
- numRedefine > 0 ifTrue:[
- categoryList add:((self class nameListEntryForRedefined bindWith:numRedefine) allItalic).
- rawProtocolList add:self class nameListEntryForRedefined.
- ].
- numDocumentation > 0 ifTrue:[
- categoryList add:((self class nameListEntryForDocumentation bindWith:numDocumentation) allItalic).
- rawProtocolList add:self class nameListEntryForDocumentation.
- ].
- numUncommented > 0 ifTrue:[
- categoryList add:((self class nameListEntryForUncommented bindWith:numUncommented) allItalic).
- rawProtocolList add:self class nameListEntryForUncommented.
- ].
- numLong > 0 ifTrue:[
- categoryList add:((self class nameListEntryForLong bindWith:numLong) allItalic).
- rawProtocolList add:self class nameListEntryForLong.
- ].
- numObsolete > 0 ifTrue:[
- categoryList add:((self class nameListEntryForObsolete bindWith:numObsolete) allItalic).
- rawProtocolList add:self class nameListEntryForObsolete.
- ].
- numExtension > 0 ifTrue:[
- categoryList add:((self class nameListEntryForExtensions bindWith:numExtension) allItalic).
- rawProtocolList add:self class nameListEntryForExtensions.
- ].
- numOverride > 0 ifTrue:[
- categoryList add:((self class nameListEntryForOverride bindWith:numOverride) allItalic).
- rawProtocolList add:self class nameListEntryForOverride.
- ].
- numMissingRequired > 0 ifTrue:[
- categoryList add:((self class nameListEntryForRequired bindWith:numMissingRequired) allItalic "colorizeAllWith:Color red").
- rawProtocolList add:self class nameListEntryForRequired.
- ].
+ addPseudoEntry := [:s :n |
+ n > 0 ifTrue:[
+ categoryList add:((s bindWith:n) allItalic colorizeAllWith:Color grey).
+ rawProtocolList add:s.
+ ].
+ ].
+
+ addPseudoEntry value:self class nameListEntryForSuperSend value:numSuper.
+ addPseudoEntry value:self class nameListEntryForRedefined value:numRedefine.
+ addPseudoEntry value:self class nameListEntryForDocumentation value:numDocumentation.
+ addPseudoEntry value:self class nameListEntryForUncommented value:numUncommented.
+ addPseudoEntry value:self class nameListEntryForLong value:numLong.
+ addPseudoEntry value:self class nameListEntryForObsolete value:numObsolete.
+ addPseudoEntry value:self class nameListEntryForExtensions value:numExtension.
+ addPseudoEntry value:self class nameListEntryForOverride value:numOverride.
+ addPseudoEntry value:self class nameListEntryForMustBeRedefinedInSubclass value:numSubclassResponsibility.
+
+ "/ I think red is too much of an alert color (and we get more of them as we think...)
+"/ numMissingRequired > 0 ifTrue:[
+"/ categoryList add:((self class nameListEntryForRequired bindWith:numMissingRequired) allItalic "colorizeAllWith:Color red").
+"/ rawProtocolList add:self class nameListEntryForRequired.
+"/ ].
+ addPseudoEntry value:self class nameListEntryForRequired value:numMissingRequired.
].
^ categoryList
@@ -1442,6 +1442,8 @@
and:[ mclass superclass notNil
and:[ (mclass superclass whichClassIncludesSelector:selector ) notNil ]]]).
+ info isSubclassResponsibility:( aMethod sends:#subclassResponsibility or:#subclassResponsibility: ).
+
MethodInfoCacheAccessLock critical:[
MethodInfoCache at:(mclass name,'>>',selector) put:info
].
@@ -1586,6 +1588,7 @@
FlagIsExtension := 32.
FlagIsOverride := 64.
FlagIsRedefine := 128.
+ FlagIsSubclassResponsibility := 128.
! !
!MethodCategoryList::CachedMethodInfo class methodsFor:'instance creation'!
@@ -1660,6 +1663,16 @@
ifFalse:[ flags bitClear: FlagIsRedefine]
!
+isSubclassResponsibility
+ ^ (flags ? 0) bitTest: FlagIsSubclassResponsibility
+!
+
+isSubclassResponsibility:aBoolean
+ flags := aBoolean
+ ifTrue:[ flags bitOr: FlagIsSubclassResponsibility ]
+ ifFalse:[ flags bitClear: FlagIsSubclassResponsibility]
+!
+
isUncommented
^ (flags ? 0) bitTest: FlagIsUncommented
!
@@ -1724,11 +1737,11 @@
!MethodCategoryList class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.47 2009-10-26 15:49:43 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.48 2009-10-26 17:28:28 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.47 2009-10-26 15:49:43 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.48 2009-10-26 17:28:28 cg Exp $'
! !
MethodCategoryList initialize!