--- a/Tools__MethodCategoryList.st Sun Jan 29 12:56:58 2012 +0000
+++ b/Tools__MethodCategoryList.st Sun Jan 29 15:33:37 2012 +0000
@@ -30,7 +30,7 @@
classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented
FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension
FlagIsRedefine FlagIsOverride FlagIsSubclassResponsibility
- FlagIsTest'
+ FlagIsTest FlagIsAnnotated'
poolDictionaries:''
privateIn:MethodCategoryList
!
@@ -456,7 +456,7 @@
or:[ (selectedCategories includes:newProtocol)
or:[ selectedCategories includes:(self class nameListEntryForALL) ]])
ifTrue:[
- self updateOutputGenerator.
+ self enqueueDelayedUpdateOutputGenerator "/ updateOutputGenerator.
].
].
@@ -492,7 +492,7 @@
((oldMethod notNil and:[selectedCategories includes:(oldMethod category)])
or:[ (newMethod notNil and:[selectedCategories includes:(newMethod category)])])
ifTrue:[
- self updateOutputGenerator.
+ self enqueueDelayedUpdateOutputGenerator "/ updateOutputGenerator.
].
].
].
@@ -593,6 +593,7 @@
changedObject == selectedProtocolsHolder ifTrue:[
rawProtocolList := rawProtocolListHolder value.
rawProtocolList size == 0 ifTrue:[
+ lastGeneratedProtocols := nil.
self updateList.
rawProtocolList := rawProtocolListHolder value.
].
@@ -607,14 +608,16 @@
setValue:nil; "/ to force update
value:newIndices.
].
- (lastGeneratedProtocols notNil
- and:[(lastGeneratedProtocols includes:self class nameListEntryForALL)
- and:[(selectedCategories ? #()) includes:self class nameListEntryForALL]])
- ifTrue:[
- "/ no need to update generator
- ] ifFalse:[
+ "/ cg: does not work (selecting all with testcase classes)
+ "/ don't see why, at the moment, but....
+"/ (lastGeneratedProtocols notNil
+"/ and:[(lastGeneratedProtocols includes:self class nameListEntryForALL)
+"/ and:[(selectedCategories ? #()) includes:self class nameListEntryForALL]])
+"/ ifTrue:[
+"/ "/ no need to update generator
+"/ ] ifFalse:[
self updateOutputGenerator.
- ]
+"/ ]
].
^ self
].
@@ -653,7 +656,7 @@
super delayedUpdate:something with:aParameter from:changedObject
"Created: / 05-02-2000 / 13:42:10 / cg"
- "Modified: / 20-07-2011 / 18:05:53 / cg"
+ "Modified: / 23-09-2011 / 20:37:31 / cg"
!
getSelectedProtocolsFromIndices
@@ -841,9 +844,11 @@
allProtocols superSendProtocols uncommentedProtocols obsoleteProtocols
documentationProtocols longProtocols extensionProtocols redefinedProtocols overrideProtocols
missingRequiredProtocols subclassResponsibilities
- notInstrumented fullyCovered partiallyCovered uncovered
+ notInstrumentedProtocols annotatedProtocols fullyCoveredProtocols
+ partiallyCoveredProtocols uncoveredProtocols
noCat static notStatic classSelectorPairsAlreadyDone
- packages remainingClasses remainingCategories classesAlreadyDone noPackage|
+ packages remainingClasses remainingCategories classesAlreadyDone noPackage
+ catListed|
noPackage := PackageId noProjectID.
noCat := (self class nameListEntryForNILCategory).
@@ -867,15 +872,17 @@
overrideProtocols := protocols includes:(self class nameListEntryForOverride).
missingRequiredProtocols := protocols includes:(self class nameListEntryForRequired).
subclassResponsibilities := protocols includes:(self class nameListEntryForMustBeRedefinedInSubclass).
- fullyCovered := protocols includes:(self class nameListEntryForFullyCovered).
- partiallyCovered := protocols includes:(self class nameListEntryForPartiallyCovered).
- uncovered := protocols includes:(self class nameListEntryForUncovered).
- notInstrumented := protocols includes:(self class nameListEntryForNotInstrumented).
+ annotatedProtocols := protocols includes:(self class nameListEntryForAnnotated).
+
+ fullyCoveredProtocols := protocols includes:(self class nameListEntryForFullyCovered).
+ partiallyCoveredProtocols := protocols includes:(self class nameListEntryForPartiallyCovered).
+ uncoveredProtocols := protocols includes:(self class nameListEntryForUncovered).
+ notInstrumentedProtocols := protocols includes:(self class nameListEntryForNotInstrumented).
-"/ packages := packageFilter value value.
-"/ (packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
-"/ packages := nil.
-"/ ].
+ packages := packageFilter value value.
+ (packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
+ packages := nil.
+ ].
remainingClasses := leafClasses copy asIdentitySet.
remainingCategories := protocols copy asSet.
@@ -897,6 +904,7 @@
aClass methodDictionary keysAndValuesDo:[:sel :mthd |
|cat mPkg includeIt info|
+"/ sel == #metacelloCleanup ifTrue:[self halt].
supportsMethodCategories ifTrue:[
cat := mthd category.
] ifFalse:[
@@ -906,9 +914,15 @@
cat := noCat.
]
].
+ catListed := cat.
+
mPkg := mthd package.
- (packages isNil or:[mPkg = noPackage or:[packages includes:mPkg]])
- ifTrue:[
+ (packages isNil
+ or:[ mPkg = noPackage
+ or:[ (packages includes:mPkg)
+ or:[ (extensionProtocols and:[ mthd isExtension ])
+ ]]]
+ ) 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)
@@ -921,7 +935,8 @@
includeIt ifFalse:[
uncommentedProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
- includeIt := info isUncommented ]].
+ includeIt := info isUncommented.
+ catListed := self class nameListEntryForUncommented ]].
includeIt ifFalse:[
obsoleteProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
@@ -937,7 +952,8 @@
includeIt ifFalse:[
extensionProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
- includeIt := info isExtensionMethod ]].
+ includeIt := info isExtensionMethod.
+ catListed := self class nameListEntryForExtensions ]].
includeIt ifFalse:[
overrideProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
@@ -950,34 +966,38 @@
subclassResponsibilities ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isSubclassResponsibility ]].
+ includeIt ifFalse:[
+ annotatedProtocols ifTrue:[
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
+ includeIt := info isAnnotated ]].
includeIt ifFalse:[
mthd isInstrumented ifTrue:[
mthd hasBeenCalled ifTrue:[
mthd haveAllBlocksBeenExecuted ifTrue:[
- includeIt := fullyCovered.
+ includeIt := fullyCoveredProtocols.
] ifFalse:[
- includeIt := partiallyCovered
+ includeIt := partiallyCoveredProtocols
]
] ifFalse:[
- includeIt := uncovered
+ includeIt := uncoveredProtocols
].
] ifFalse:[
- includeIt := notInstrumented
+ includeIt := notInstrumentedProtocols
].
].
includeIt ifTrue:[
(methodVisibilityHolder value == #class) ifTrue:[
- whatToDo value:aClass value:cat value:sel value:mthd.
+ whatToDo value:aClass value:catListed value:sel value:mthd.
] ifFalse:[
(classSelectorPairsAlreadyDone includes:(aLeafClass->sel)) ifFalse:[
classSelectorPairsAlreadyDone add:(aLeafClass->sel).
- whatToDo value:aClass value:cat value:sel value:mthd.
+ whatToDo value:aClass value:catListed value:sel value:mthd.
].
].
anyInThisClass := true.
- remainingCategories remove:cat ifAbsent:nil.
+ remainingCategories remove:catListed ifAbsent:nil.
].
]
].
@@ -1006,7 +1026,7 @@
]
"Created: / 05-02-2000 / 13:42:10 / cg"
- "Modified: / 20-07-2011 / 18:43:48 / cg"
+ "Modified: / 18-09-2011 / 12:51:45 / cg"
! !
!MethodCategoryList methodsFor:'private'!
@@ -1129,8 +1149,8 @@
packageFilterOnInput packageFilter nameListEntryForALL changeSet
emphasizedPlus emphasisForRef emphasisForMod
numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride
- numRedefine numExtension numMissingRequired numSubclassResponsibility
- numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
+ numRedefine numExtension numMissingRequired numSubclassResponsibility
+ numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
showPseudoProtocols showCoverageInformation
addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
startTime lazyPseudoProtocols|
@@ -1180,6 +1200,7 @@
numObsolete := numSuper := numUncommented := numDocumentation := numLong := 0.
numRedefine := numOverride := numExtension := numMissingRequired := numSubclassResponsibility := 0.
numNotInstrumented := numFullyCovered := numPartiallyCovered := numUncovered := 0.
+ numAnnotated := 0.
generator do:[:clsIn :catIn |
|emptyProtocols clsName doHighLight doHighLightRed suppress|
@@ -1239,9 +1260,10 @@
info isOverride ifTrue:[ numOverride := numOverride + 1 ].
info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
+ info isAnnotated ifTrue:[ numAnnotated := numAnnotated + 1].
]
].
- (Timestamp now deltaFrom:startTime) > 10 seconds ifTrue:[
+ (Timestamp now deltaFrom:startTime) > 5 seconds ifTrue:[
lazyPseudoProtocols := true.
"/ because we already computed for 10seconds, more and more will be found in
"/ the cache, and eventually, pseudo protocols will be shown anyway
@@ -1289,7 +1311,7 @@
]
].
mPackage ~~ classPackage ifTrue:[
- mPackage ~= PackageId noProjectID ifTrue:[
+ (mCategory notNil and:[mPackage ~= PackageId noProjectID]) ifTrue:[
itemsWithExtensions add:mCategory.
(packageFilter notNil
@@ -1474,6 +1496,7 @@
addPseudoEntry value:self class nameListEntryForExtensions value:numExtension.
addPseudoEntry value:self class nameListEntryForOverride value:numOverride.
addPseudoEntry value:self class nameListEntryForMustBeRedefinedInSubclass value:numSubclassResponsibility.
+ addPseudoEntry value:self class nameListEntryForAnnotated value:numAnnotated.
showCoverageInformation ifTrue:[
addPseudoEntryWithColor value:self class nameListEntryForPartiallyCovered value:numPartiallyCovered value:userPreferences colorForInstrumentedPartiallyCoveredCode.
addPseudoEntryWithColor value:self class nameListEntryForUncovered value:numUncovered value:userPreferences colorForInstrumentedNeverCalledCode.
@@ -1491,7 +1514,8 @@
^ categoryList
"Created: / 05-02-2000 / 13:42:11 / cg"
- "Modified: / 18-08-2011 / 10:04:40 / cg"
+ "Modified: / 31-08-2011 / 16:26:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 08-09-2011 / 04:56:47 / cg"
!
makeDependent
@@ -1584,7 +1608,7 @@
!
methodInfoFor:aMethod in:mclass selector:selector lazy:lazy
- |info isDocumentationMethod isVersionMethod def|
+ |info isDocumentationMethod isVersionMethod def methodsPackage|
"/ the first at:ifAbsent: is aktually not needed - it is here to
"/ reduce the average blocking time, and to allow for debugging the info generating
@@ -1598,31 +1622,39 @@
"/ notify me to update the list, when all the lazy info is avail...
] ifFalse:[
true "aMethod mclass language isSmalltalk" ifTrue:[
- info := CachedMethodInfo new.
- info isObsolete:(aMethod isObsolete).
- info sendsSuper:(aMethod superMessages notEmptyOrNil).
- info isUncommented:(self methodIsMarkedAsUncommented:aMethod).
+ methodsPackage := aMethod package.
+
isVersionMethod := aMethod isVersionMethod.
isDocumentationMethod := isVersionMethod not and:[aMethod isDocumentationMethod].
+
+ info := CachedMethodInfo new.
+ info isObsolete:(aMethod isObsolete). "/ (aMethod isObsolete).
+ info sendsSuper:(aMethod superMessages notEmptyOrNil). "/ (aMethod superMessages notEmptyOrNil).
+ info isUncommented:(self methodIsMarkedAsUncommented:aMethod). "/ (self methodIsMarkedAsUncommented:aMethod).
info isDocumentationMethod:isDocumentationMethod.
- info isLongMethod:( self methodIsMarkedAsLong:aMethod ).
+ info isLongMethod:(self methodIsMarkedAsLong:aMethod). "/ (self methodIsMarkedAsLong:aMethod).
- aMethod package ~= mclass package ifTrue:[
- aMethod package ~= #'__NoProject__' ifTrue:[
+ methodsPackage ~= mclass package ifTrue:[
+ methodsPackage ~= #'__NoProject__' ifTrue:[
info isExtensionMethod:true.
- info isOverride:( (def := aMethod package asPackageId projectDefinitionClass) notNil
- and:[ (def methodOverwrittenBy:aMethod ) notNil ])
+ info isOverride:(
+ ((def := methodsPackage asPackageId projectDefinitionClass) notNil
+ and:[ (def methodOverwrittenBy:aMethod ) notNil ])
+ )
]
] ifFalse:[
info isExtensionMethod:false.
info isOverride:false.
].
- info isRedefine:( isVersionMethod not
- and:[ isDocumentationMethod not
- and:[ mclass superclass notNil
- and:[ (mclass superclass whichClassIncludesSelector:selector ) notNil ]]]).
+ info isRedefine:(
+ ( isVersionMethod not
+ and:[ isDocumentationMethod not
+ and:[ mclass superclass notNil
+ and:[ (mclass superclass whichClassIncludesSelector:selector ) notNil ]]])
+ ).
info isSubclassResponsibility:( aMethod sends:#subclassResponsibility or:#subclassResponsibility: ).
+ info isAnnotated:(aMethod hasAnnotation).
MethodInfoCacheAccessLock critical:[
MethodInfoCache at:(mclass name,'>>',selector) put:info
@@ -1773,8 +1805,10 @@
FlagIsRedefine := 128.
FlagIsSubclassResponsibility := 128.
FlagIsTest := 256.
+ FlagIsAnnotated := 512.
"Modified: / 08-03-2010 / 18:33:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 07-09-2011 / 10:04:30 / cg"
! !
!MethodCategoryList::CachedMethodInfo class methodsFor:'instance creation'!
@@ -1789,6 +1823,20 @@
flags := something.
!
+isAnnotated
+ ^ (flags ? 0) bitTest: FlagIsAnnotated
+
+ "Created: / 07-09-2011 / 10:04:56 / cg"
+!
+
+isAnnotated:aBoolean
+ flags := aBoolean
+ ifTrue:[ flags bitOr: FlagIsAnnotated ]
+ ifFalse:[ flags bitClear: FlagIsAnnotated]
+
+ "Created: / 07-09-2011 / 10:04:48 / cg"
+!
+
isDocumentationMethod
^ (flags ? 0) bitTest: FlagIsDocumentationMethod
!
@@ -1931,12 +1979,12 @@
!MethodCategoryList class methodsFor:'documentation'!
version
- ^ '$Id: Tools__MethodCategoryList.st 7819 2011-08-19 08:54:18Z vranyj1 $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.77 2011/09/23 18:56:37 cg Exp $'
!
version_CVS
- ^ '§Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.71 2011/08/18 08:05:43 cg Exp §'
+ ^ '§Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.77 2011/09/23 18:56:37 cg Exp §'
! !
MethodCategoryList initialize!
-MethodCategoryList::CachedMethodInfo initialize!
\ No newline at end of file
+MethodCategoryList::CachedMethodInfo initialize!