hg/stx-libtool: comparison Tools_

equal deleted inserted replaced

-:86df5844137f
+:0c49a3b13e43
 Object subclass:#CachedMethodInfo
 	instanceVariableNames:'flags'
 	classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented
 		FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension
 		FlagIsRedefine FlagIsOverride FlagIsSubclassResponsibility
-		FlagIsTest'
+		FlagIsTest FlagIsAnnotated'
 	poolDictionaries:''
 	privateIn:MethodCategoryList
 !
 Method variableSubclass:#MissingMethod
 ((selectedCategories includes:oldProtocol)
 or:[ (selectedCategories includes:newProtocol)
 or:[ selectedCategories includes:(self class nameListEntryForALL) ]])
 ifTrue:[
-self updateOutputGenerator.
+self enqueueDelayedUpdateOutputGenerator "/ updateOutputGenerator.
 ].
 ].
 ].
 ^ self
 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 enqueueDelayedUpdateOutputGenerator "/ updateOutputGenerator.
 ].
 ].
 ].
 ^ self.
 ].
 ].
 changedObject == selectedProtocolsHolder ifTrue:[
 rawProtocolList := rawProtocolListHolder value.
 rawProtocolList size == 0 ifTrue:[
+lastGeneratedProtocols := nil.
 self updateList.
 rawProtocolList := rawProtocolListHolder value.
 ].
 rawProtocolList notNil ifTrue:[
 selectedCategories := selectedProtocolsHolder value ? #().
 newIndices ~= self selectedProtocolIndices value ifTrue:[
 self selectedProtocolIndices
 setValue:nil;                    "/ to force update
 value:newIndices.
 ].
-(lastGeneratedProtocols notNil
+"/ cg: does not work (selecting all with testcase classes)
-and:[(lastGeneratedProtocols includes:self class nameListEntryForALL)
+"/ don't see why, at the moment, but....
-and:[(selectedCategories ? #()) includes:self class nameListEntryForALL]])
+"/            (lastGeneratedProtocols notNil
-ifTrue:[
+"/            and:[(lastGeneratedProtocols includes:self class nameListEntryForALL)
-"/ no need to update generator
+"/            and:[(selectedCategories ? #()) includes:self class nameListEntryForALL]])
-] ifFalse:[
+"/            ifTrue:[
+"/                "/ no need to update generator
+"/            ] ifFalse:[
 self updateOutputGenerator.
-]
+"/            ]
 ].
 ^ self
 ].
 (changedObject == variableFilter
 ].
 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
 |l|
 on:[:whatToDo |
 |protocols
 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).
 static := (self class nameListEntryForStatic).
 notStatic := (self class nameListEntryForNonStatic).
 extensionProtocols := protocols includes:(self class nameListEntryForExtensions).
 redefinedProtocols := protocols includes:(self class nameListEntryForRedefined).
 overrideProtocols := protocols includes:(self class nameListEntryForOverride).
 missingRequiredProtocols := protocols includes:(self class nameListEntryForRequired).
 subclassResponsibilities := protocols includes:(self class nameListEntryForMustBeRedefinedInSubclass).
-fullyCovered := protocols includes:(self class nameListEntryForFullyCovered).
+annotatedProtocols := protocols includes:(self class nameListEntryForAnnotated).
-partiallyCovered := protocols includes:(self class nameListEntryForPartiallyCovered).
-uncovered := protocols includes:(self class nameListEntryForUncovered).
+fullyCoveredProtocols := protocols includes:(self class nameListEntryForFullyCovered).
-notInstrumented := protocols includes:(self class nameListEntryForNotInstrumented).
+partiallyCoveredProtocols := protocols includes:(self class nameListEntryForPartiallyCovered).
+uncoveredProtocols := protocols includes:(self class nameListEntryForUncovered).
+notInstrumentedProtocols := protocols includes:(self class nameListEntryForNotInstrumented).
-"/                packages := packageFilter value value.
+packages := packageFilter value value.
-"/                (packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
+(packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
-"/                    packages := nil.
+packages := nil.
-"/                ].
+].
 remainingClasses := leafClasses copy asIdentitySet.
 remainingCategories := protocols copy asSet.
 classesAlreadyDone := IdentitySet new.
 anyInThisClass := false.
 aClass methodDictionary keysAndValuesDo:[:sel :mthd |
 |cat mPkg includeIt info|
+"/ sel == #metacelloCleanup ifTrue:[self halt].
 supportsMethodCategories ifTrue:[
 cat := mthd category.
 ] ifFalse:[
 isJavaClass ifTrue:[
 cat := mthd isStatic ifTrue:[static] ifFalse:[notStatic]
 ] ifFalse:[
 cat := noCat.
 ]
 ].
+catListed := cat.
 mPkg := mthd package.
-(packages isNil or:[mPkg = noPackage or:[packages includes:mPkg]])
+(packages isNil
-ifTrue:[
+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)
 includeIt := allProtocols.
 includeIt ifFalse:[ includeIt := protocols includes:cat ].
 info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
 includeIt := info sendsSuper ]].
 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 ].
 includeIt := info isObsolete ]].
 includeIt ifFalse:[
 info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
 includeIt := info isLongMethod ]].
 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 ].
 includeIt := info isOverride ]].
 includeIt ifFalse:[
 includeIt := info isRedefine ]].
 includeIt ifFalse:[
 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.
 ].
 ]
 ].
 missingRequiredProtocols ifTrue:[
 ]
 ]
 ]
 "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'!
 class:cls protocol:cat includesMethodsInAnyPackage:packageFilter
 itemsWithInstrumentedMethods itemsWithCalledMethods itemsWithUncalledMethods
 itemsWithPartiallyCoveredMethods itemsWithFullyCoveredMethods
 packageFilterOnInput packageFilter nameListEntryForALL changeSet
 emphasizedPlus emphasisForRef emphasisForMod
 numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride
 numRedefine numExtension numMissingRequired numSubclassResponsibility
-numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
+numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
 showPseudoProtocols showCoverageInformation
 addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
 startTime lazyPseudoProtocols|
 userPreferences := UserPreferences current.
 variablesToHighlight := variableFilter value.
 classVarsToHighLight := filterClassVars value.
 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|
 leafClassesProcessed add:clsIn.
 info isLongMethod ifTrue:[ numLong := numLong + 1 ].
 info isExtensionMethod ifTrue:[ numExtension := numExtension + 1 ].
 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
 masterApplication showInfo:'suppress pseudo protocols - parsing took too long'.
 ].
 mPackage ~~ classPackage ifTrue:[
 mthd setPackage:(mPackage := mPackage string asSymbol).
 ]
 ].
 mPackage ~~ classPackage ifTrue:[
-mPackage ~= PackageId noProjectID ifTrue:[
+(mCategory notNil and:[mPackage ~= PackageId noProjectID]) ifTrue:[
 itemsWithExtensions add:mCategory.
 (packageFilter notNil
 and:[ (packageFilter includes:mPackage) not])
 ifTrue:[
 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.
+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.
 addPseudoEntryWithColor value:self class nameListEntryForFullyCovered value:numFullyCovered value:userPreferences colorForInstrumentedFullyCoveredCode.
 addPseudoEntry value:self class nameListEntryForNotInstrumented value:numNotInstrumented.
 addPseudoEntry value:self class nameListEntryForRequired value:numMissingRequired.
 ].
 ^ 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
 Smalltalk addDependent:self.
 "/    ChangeSet addDependent:self.
 "Modified: / 08-08-2011 / 18:21:03 / cg"
 !
 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
 "/ code without deadlock
 MethodInfoCacheAccessLock critical:[
 lazy ifTrue:[
 "/ TODO: start a background thread to compute the stuff below,
 "/ notify me to update the list, when all the lazy info is avail...
 ] ifFalse:[
 true "aMethod mclass language isSmalltalk" ifTrue:[
-info := CachedMethodInfo new.
+methodsPackage := aMethod package.
-info isObsolete:(aMethod isObsolete).
-info sendsSuper:(aMethod superMessages notEmptyOrNil).
-info isUncommented:(self methodIsMarkedAsUncommented:aMethod).
 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:[
+methodsPackage ~= mclass package ifTrue:[
-aMethod package ~= #'__NoProject__' ifTrue:[
+methodsPackage ~= #'__NoProject__' ifTrue:[
 info isExtensionMethod:true.
-info isOverride:( (def := aMethod package asPackageId projectDefinitionClass) notNil
+info isOverride:(
-and:[ (def methodOverwrittenBy:aMethod ) notNil ])
+((def := methodsPackage asPackageId projectDefinitionClass) notNil
+and:[ (def methodOverwrittenBy:aMethod ) notNil ])
+)
 ]
 ] ifFalse:[
 info isExtensionMethod:false.
 info isOverride:false.
 ].
-info isRedefine:( isVersionMethod not
+info isRedefine:(
-and:[ isDocumentationMethod not
+( isVersionMethod not
-and:[ mclass superclass notNil
+and:[ isDocumentationMethod not
-and:[ (mclass superclass whichClassIncludesSelector:selector ) notNil ]]]).
+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
 ].
 ].
 FlagIsExtension := 32.
 FlagIsOverride := 64.
 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'!
 new
 !MethodCategoryList::CachedMethodInfo methodsFor:'accessing'!
 flags:something
 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
 !
 ! !
 !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!

branch	jv
changeset 12125	0c49a3b13e43
parent 12123	4bde08cebd48
child 12128	a7ff7d66ee85