--- a/Tools__MethodCategoryList.st Sun Nov 03 11:19:20 2019 +0100
+++ b/Tools__MethodCategoryList.st Sun Nov 03 15:59:37 2019 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2000 by eXept Software AG
All Rights Reserved
@@ -30,7 +32,8 @@
classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented
FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension
FlagIsRedefine FlagIsRedefined FlagIsOverride
- FlagIsSubclassResponsibility FlagIsTest FlagIsAnnotated'
+ FlagIsSubclassResponsibility FlagIsTest FlagIsAnnotated
+ FlagIsInChangeSet'
poolDictionaries:''
privateIn:MethodCategoryList
!
@@ -753,6 +756,8 @@
update:something with:aParameter from:changedObject
|cls sel mthd oldMethod newMethod|
+ listValid := listValid ? false.
+
"/ some can be ignored immediately
changedObject == environment ifTrue:[
something isNil ifTrue:[
@@ -761,7 +766,7 @@
].
something == #currentChangeSet ifTrue:[
- listValid == true ifTrue:[ self invalidateList ].
+ listValid ifTrue:[ self invalidateList ].
^ self.
].
@@ -771,21 +776,23 @@
(classes notNil and:[classes includesIdentical:cls]) ifFalse:[^ self].
sel := aParameter at:2.
- self flushMethodInfoForClassNamed:cls name selector:sel.
+ self flushMethodInfoForClassNamed:(cls name) selector:sel.
+ listValid ifFalse:[^ self ].
+
oldMethod := aParameter at:3.
newMethod := cls compiledMethodAt:sel.
oldMethod notNil ifTrue:[
variableFilter value size ~~ 0 ifTrue:[
"/ sigh - must invalidate
- listValid ifTrue:[ self invalidateList ].
+ self invalidateList.
^ self.
].
oldMethod category ~= newMethod category ifTrue:[
- listValid ifTrue:[ self invalidateList ].
+ self invalidateList.
^ self.
].
"/ mhmh - its now changed (so coloring will change).
- listValid ifTrue:[ self invalidateList ].
+ self invalidateList.
^ self.
].
].
@@ -816,8 +823,8 @@
].
something == #methodCoverageInfo ifTrue:[
+ listValid ifFalse:[^ self ].
self showCoverageInformation value ifFalse:[^ self].
- listValid ifFalse:[^ self ].
mthd := aParameter.
(classes notNil and:[classes includesIdentical:mthd mclass]) ifFalse:[^ self].
@@ -829,6 +836,7 @@
].
something == #lastTestRunResult ifTrue:[
+ listValid ifFalse:[^ self ].
cls := aParameter at:1.
(classes notNil and:[classes includesIdentical:cls]) ifTrue:[
self invalidateList.
@@ -922,11 +930,11 @@
documentationProtocols longProtocols extensionProtocols redefinedProtocols
redefineProtocols overrideProtocols
missingRequiredProtocols subclassResponsibilities
- anyCoverage notInstrumentedProtocols annotatedProtocols fullyCoveredProtocols
+ anyCoverage notInstrumentedProtocols annotatedProtocols inChangeSetProtocols fullyCoveredProtocols
partiallyCoveredProtocols uncoveredProtocols allTestsProtocols allTestsNotPassedProtocols
classSelectorPairsAlreadyDone
packages remainingClasses remainingCategories classesAlreadyDone
- catListed showChanged|
+ catListed showChanged includedExtensionPackages|
leafClasses remove:nil ifAbsent:[]. "/ may happen when hierarchies are changed elsewhere.
@@ -936,7 +944,7 @@
obsoleteProtocols := documentationProtocols := longProtocols := false.
extensionProtocols := redefinedProtocols := redefineProtocols := false.
overrideProtocols := missingRequiredProtocols := subclassResponsibilities := false.
- annotatedProtocols := false.
+ annotatedProtocols := inChangeSetProtocols := false.
fullyCoveredProtocols := partiallyCoveredProtocols := uncoveredProtocols := false.
notInstrumentedProtocols := anyCoverage := allTestsProtocols := false.
allTestsNotPassedProtocols := false.
@@ -956,6 +964,8 @@
missingRequiredProtocols := protocols includes:(self class nameListEntryForRequired).
subclassResponsibilities := protocols includes:(self class nameListEntryForMustBeRedefinedInSubclass).
annotatedProtocols := protocols includes:(self class nameListEntryForAnnotated).
+ inChangeSetProtocols := protocols includes:(self class nameListEntryForChanged).
+ inChangeSetProtocols := inChangeSetProtocols or:[ protocols includes:(self class nameListEntryForChangedWithCount) ].
fullyCoveredProtocols := protocols includes:(self class nameListEntryForFullyCovered).
partiallyCoveredProtocols := protocols includes:(self class nameListEntryForPartiallyCovered).
@@ -966,6 +976,12 @@
allTestsProtocols := protocols includes:(self class nameListEntryForAllTests).
allTestsNotPassedProtocols := protocols includes:(self class nameListEntryForTestsNotPassed).
+
+ includedExtensionPackages := protocols
+ select:[:p | (p startsWith:'* extension')
+ and:[ p includesAll:'{}' ].
+ ]
+ thenCollect:[:p | (p copyBetween:'{' and:'}' caseSensitive:true) withoutSpaces ].
].
].
@@ -1073,7 +1089,9 @@
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isExtensionMethod.
catListed := self class nameListEntryForExtensions ]].
-
+ includeIt ifFalse:[
+ includedExtensionPackages notEmptyOrNil ifTrue:[
+ includeIt := includedExtensionPackages includes:mthd package ]].
includeIt ifFalse:[
overrideProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
@@ -1116,6 +1134,11 @@
].
].
].
+ includeIt ifFalse:[
+ inChangeSetProtocols ifTrue:[
+ includeIt := ChangeSet current includesChangeForClass:aClass selector:sel.
+ ].
+ ].
].
includeIt ifTrue:[
@@ -1272,9 +1295,7 @@
flushMethodInfoForClassNamed:className selector:selector
MethodInfoCacheAccessLock critical:[
MethodInfoCache notNil ifTrue:[
- MethodInfoCache
- removeKey:(className,'>>',selector)
- ifAbsent:[]
+ MethodInfoCache removeKey:(className,'>>',selector) ifAbsent:[]
].
]
@@ -1284,7 +1305,8 @@
listOfMethodCategories
|categoryList categoryBag plainCategories classesProcessed leafClassesProcessed
generator nm variablesToHighlight classVarsToHighLight
- itemsWithVarRefs itemsWithVarMods itemsWithExtensions itemsWithSuppressedExtensions
+ itemsWithVarRefs itemsWithVarMods itemsWithExtensions
+ itemsWithSuppressedExtensions
itemsInChangeSet itemsInRemoteChangeSet
itemsWithInstrumentedMethods itemsWithCalledMethods itemsWithUncalledMethods
itemsWithPartiallyCoveredMethods itemsWithFullyCoveredMethods
@@ -1292,8 +1314,9 @@
packageFilterOnInput packageFilter showChanges nameListEntryForALL changeSet
emphasizedPlus emphasisForRef emphasisForMod
numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride
- numRedefine numRedefined numExtension numMissingRequired numSubclassResponsibility
- numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
+ numRedefine numRedefined numExtension numItemsWithExtensionsPerPackage
+ numMissingRequired numSubclassResponsibility
+ numAnnotated numInChanged numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
numAllTestResults numTestsNotPassed
showPseudoProtocols showCoverageInformation
addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
@@ -1333,6 +1356,7 @@
itemsWithVarRefs := Set new.
itemsWithVarMods := Set new.
itemsWithExtensions := Set new.
+ numItemsWithExtensionsPerPackage := Dictionary new.
itemsWithSuppressedExtensions := Set new.
itemsInChangeSet := Set new.
itemsInRemoteChangeSet := Set new.
@@ -1353,7 +1377,7 @@
numObsolete := numSuper := numUncommented := numDocumentation := numLong := 0.
numRedefine := numRedefined := numOverride := numExtension := numMissingRequired := numSubclassResponsibility := 0.
numNotInstrumented := numFullyCovered := numPartiallyCovered := numUncovered := 0.
- numAnnotated := numAllTestResults := numTestsNotPassed := 0.
+ numAnnotated := numInChanged := numAllTestResults := numTestsNotPassed := 0.
inheritedTestSelectors := Set new.
numAll := 0.
@@ -1440,7 +1464,10 @@
info isUncommented ifTrue:[ numUncommented := numUncommented + 1 ].
info isDocumentationMethod ifTrue:[ numDocumentation := numDocumentation + 1 ].
info isLongMethod ifTrue:[ numLong := numLong + 1 ].
- info isExtensionMethod ifTrue:[ numExtension := numExtension + 1 ].
+ info isExtensionMethod ifTrue:[
+ numExtension := numExtension + 1.
+ numItemsWithExtensionsPerPackage at:mthd package ifAbsent:0 update:[:n | n + 1].
+ ].
info isOverride ifTrue:[ numOverride := numOverride + 1 ].
info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
info isRedefined ifTrue:[ numRedefined := numRedefined + 1 ].
@@ -1494,7 +1521,7 @@
ifTrue:[
itemsWithSuppressedExtensions add:mCategory.
] ifFalse:[
- itemsWithExtensions add:mCategory.
+ itemsWithExtensions add:mCategory.
]
].
].
@@ -1528,7 +1555,8 @@
ifTrue:[
"/ itemsInChangeSetSuppressed add:mCategory.
] ifFalse:[
- itemsInChangeSet add:mCategory.
+ itemsInChangeSet add:mCategory.
+ numInChanged := numInChanged + 1.
]
].
(SmallTeam notNil and:[ SmallTeam includesChangeForClass:eachClass selector:mSelector] ) ifTrue:[
@@ -1707,17 +1735,37 @@
(showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
addPseudoEntryWithColor := [:s :n :clr |
n > 0 ifTrue:[
- categoryList
- add:((s bindWith:n) allItalic withColor:clr).
+ categoryList add:((s bindWith:n) allItalic withColor:clr).
+ rawProtocolList add:s.
+ ].
+ ].
+
+ addPseudoEntry := [:s :n |
+ n > 0 ifTrue:[
+ categoryList add:((s bindWith:n) allItalic withColor:pseudoEntryColor).
rawProtocolList add:s.
].
].
- addPseudoEntry := [:s :n | addPseudoEntryWithColor value:s value:n value:pseudoEntryColor].
-
addPseudoEntry value:self class nameListEntryForAnnotated value:numAnnotated.
addPseudoEntry value:self class nameListEntryForDocumentation value:numDocumentation.
addPseudoEntry value:self class nameListEntryForExtensions value:numExtension.
+ numExtension > 0 ifTrue:[
+ numItemsWithExtensionsPerPackage keys asOrderedCollection sort do:[:eachExtensionPackage |
+ |count listEntry|
+ count := numItemsWithExtensionsPerPackage at:eachExtensionPackage.
+ listEntry := self class nameListEntryTemplateForExtensionsPerPackage.
+ categoryList add:((listEntry bindWith:count with:eachExtensionPackage) allItalic withColor:pseudoEntryColor).
+ rawProtocolList add:listEntry.
+ ].
+ ].
+ numInChanged > 0 ifTrue:[
+ |listEntry|
+
+ listEntry := self class nameListEntryForChangedWithCount.
+ categoryList add:((listEntry bindWith:numInChanged) allItalic withColor:pseudoEntryColor).
+ rawProtocolList add:listEntry.
+ ].
addPseudoEntry value:self class nameListEntryForLong value:numLong.
addPseudoEntry value:self class nameListEntryForMustBeRedefinedInSubclass value:numSubclassResponsibility.
addPseudoEntry value:self class nameListEntryForObsolete value:numObsolete.
@@ -2077,6 +2125,7 @@
FlagIsTest := 256.
FlagIsAnnotated := 512.
FlagIsRedefined := 1024.
+ FlagIsInChangeSet := 2048.
"Modified: / 08-03-2010 / 18:33:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-09-2011 / 10:04:30 / cg"
@@ -2090,8 +2139,8 @@
!MethodCategoryList::CachedMethodInfo methodsFor:'accessing'!
-flags:something
- flags := something.
+flags:anInteger
+ flags := anInteger.
!
isAnnotated
@@ -2128,6 +2177,18 @@
ifFalse:[ flags bitClear: FlagIsExtension]
!
+isInChangeSet
+ ^ (flags ? 0) bitTest: FlagIsInChangeSet
+!
+
+isInChangeSet:aBoolean
+ flags := aBoolean
+ ifTrue:[ flags bitOr: FlagIsInChangeSet ]
+ ifFalse:[ flags bitClear: FlagIsInChangeSet]
+
+ "Created: / 07-09-2011 / 10:04:48 / cg"
+!
+
isLongMethod
^ (flags ? 0) bitTest: FlagIsLongMethod
!