--- a/Tools__MethodCategoryList.st Thu Feb 26 03:51:21 2015 +0100
+++ b/Tools__MethodCategoryList.st Thu Feb 26 04:58:30 2015 +0100
@@ -18,7 +18,7 @@
leafClasses protocolList rawProtocolList selectedProtocolIndices
lastGeneratedProtocols packageFilterOnInput
methodVisibilityHolder noAllItem noPseudoItems
- showPseudoProtocols'
+ showPseudoProtocols showSyntheticMethods'
classVariableNames:'AdditionalEmptyCategoriesPerClassName MethodInfoCache
MethodInfoCacheAccessLock'
poolDictionaries:''
@@ -42,6 +42,13 @@
privateIn:MethodCategoryList
!
+MethodCategoryList::MissingMethod variableSubclass:#MethodStubForTestResult
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:MethodCategoryList
+!
+
!MethodCategoryList class methodsFor:'documentation'!
copyright
@@ -219,6 +226,7 @@
#variableFilter
#methodVisibilityHolder
#showCoverageInformation
+ #showSyntheticMethods
).
"Modified: / 27-04-2010 / 16:40:39 / cg"
@@ -386,6 +394,24 @@
].
!
+showSyntheticMethods
+ showSyntheticMethods isNil ifTrue:[
+ showSyntheticMethods := ValueHolder with:true.
+ showSyntheticMethods addDependent:self
+ ].
+ ^ showSyntheticMethods
+!
+
+showSyntheticMethods:aValueHolder
+ showSyntheticMethods notNil ifTrue:[
+ showSyntheticMethods removeDependent:self
+ ].
+ showSyntheticMethods := aValueHolder.
+ showSyntheticMethods notNil ifTrue:[
+ showSyntheticMethods addDependent:self
+ ].
+!
+
variableFilter
variableFilter isNil ifTrue:[
variableFilter := ValueHolder with:false.
@@ -884,7 +910,7 @@
redefineProtocols overrideProtocols
missingRequiredProtocols subclassResponsibilities
notInstrumentedProtocols annotatedProtocols fullyCoveredProtocols
- partiallyCoveredProtocols uncoveredProtocols
+ partiallyCoveredProtocols uncoveredProtocols allTestsProtocols
classSelectorPairsAlreadyDone
packages remainingClasses remainingCategories classesAlreadyDone
catListed showChanged|
@@ -908,7 +934,9 @@
partiallyCoveredProtocols := protocols includes:(self class nameListEntryForPartiallyCovered).
uncoveredProtocols := protocols includes:(self class nameListEntryForUncovered).
notInstrumentedProtocols := protocols includes:(self class nameListEntryForNotInstrumented).
-
+
+ allTestsProtocols := protocols includes:(self class nameListEntryForAllTests).
+
packages := packageFilter value value.
(packages notNil and:[packages includes:(self class nameListEntryForALL)]) ifTrue:[
packages := nil.
@@ -923,13 +951,22 @@
leafClasses do:[:aLeafClass |
(self classesToProcessForClasses:(Array with:aLeafClass)) do:[:aClass |
- |supportsMethodCategories isJavaClass anyInThisClass requiredProtocolForClass|
+ |supportsMethodCategories isJavaClass anyInThisClass requiredProtocolForClass
+ isTestCase allTestSelectors|
(classesAlreadyDone includes:aClass) ifFalse:[
classesAlreadyDone add:aClass.
supportsMethodCategories := aClass supportsMethodCategories.
isJavaClass := aClass isJavaClass.
+ (allTestsProtocols) ifTrue:[
+ isTestCase := aClass isMetaclass not and:[aClass isTestCaseLike and:[aClass isAbstract not]].
+ isTestCase ifTrue:[
+ allTestsProtocols ifTrue:[
+ allTestSelectors := aClass allTestSelectors asSet.
+ ].
+ ].
+ ].
anyInThisClass := false.
aClass methodDictionary keysAndValuesDo:[:sel :mthd |
@@ -958,7 +995,11 @@
"/ 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 ].
+ includeIt ifFalse:[
+ includeIt := protocols includes:cat].
+ includeIt ifFalse:[
+ allTestsProtocols ifTrue:[
+ includeIt := allTestSelectors notNil and:[allTestSelectors includes:sel]]].
includeIt ifFalse:[
superSendProtocols ifTrue:[
info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
@@ -1034,7 +1075,8 @@
anyInThisClass := true.
remainingCategories remove:catListed ifAbsent:nil.
].
- ]
+ ].
+ allTestSelectors notNil ifTrue:[ allTestSelectors remove: sel ifAbsent:[] ].
].
missingRequiredProtocols ifTrue:[
@@ -1047,6 +1089,15 @@
whatToDo value:aClass value:'required' value:selectorInRed value:missingMethodPlaceHolder.
].
].
+ allTestSelectors notEmptyOrNil ifTrue:[
+ allTestSelectors do:[:sel |
+ |methodPlaceHolder implClass|
+
+ implClass := aClass whichClassImplements:sel.
+ methodPlaceHolder := MethodStubForTestResult mclass:implClass selector:sel.
+ whatToDo value:aClass value:'all tests' value:sel value:methodPlaceHolder.
+ ].
+ ].
anyInThisClass ifTrue:[ remainingClasses remove:aClass ifAbsent:nil. ].
].
].
@@ -1185,8 +1236,7 @@
emphasizedPlus emphasisForRef emphasisForMod
numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride
numRedefine numRedefined numExtension numMissingRequired numSubclassResponsibility
- numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
- showPseudoProtocols showCoverageInformation
+ numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented numAllTestResults showPseudoProtocols showCoverageInformation
addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
startTime suppressPseudoProtocolsNow needsSpecialColoring|
@@ -1239,115 +1289,122 @@
numObsolete := numSuper := numUncommented := numDocumentation := numLong := 0.
numRedefine := numRedefined := numOverride := numExtension := numMissingRequired := numSubclassResponsibility := 0.
numNotInstrumented := numFullyCovered := numPartiallyCovered := numUncovered := 0.
- numAnnotated := 0.
+ numAnnotated := numAllTestResults := 0.
numAll := 0.
generator do:[:clsIn :catIn |
- |emptyProtocols clsName doHighLight doHighLightRed includedCats|
+ |emptyProtocols clsName doHighLight doHighLightRed includedCats|
- includedCats := Set new.
+ includedCats := Set new.
- leafClassesProcessed add:clsIn.
- (self classesToProcessForClasses:(Array with:clsIn)) do:[:cls |
- |cats processCategory|
+ leafClassesProcessed add:clsIn.
+ (self classesToProcessForClasses:(Array with:clsIn)) do:[:cls |
+ |cats processCategory|
- classesProcessed add:cls.
+ classesProcessed add:cls.
- cls ~~ clsIn ifTrue:[
- cats := cls categories
- ] ifFalse:[
- cats := Array with:catIn.
- ].
- cats do:[:cat |
- |suppress|
+ cls ~~ clsIn ifTrue:[
+ cats := cls categories
+ ] ifFalse:[
+ cats := Array with:catIn.
+ ].
+ cats do:[:cat |
+ |suppress|
- cat notNil ifTrue:[
- suppress := packageFilterOnInput notNil
- and:[ (self class:cls protocol:cat includesMethodsInAnyPackage:packageFilterOnInput) not ].
- suppress ifFalse:[
- includedCats add:cat.
+ cat notNil ifTrue:[
+ suppress := packageFilterOnInput notNil
+ and:[ (self class:cls protocol:cat includesMethodsInAnyPackage:packageFilterOnInput) not ].
+ suppress ifFalse:[
+ includedCats add:cat.
- variablesToHighlight notEmptyOrNil ifTrue:[
- (itemsWithVarRefs includes:cat) ifFalse:[
- classVarsToHighLight ifTrue:[
- doHighLight := self class:cls protocol:cat includesRefsToClassVariable:variablesToHighlight.
- doHighLight ifTrue:[
- doHighLightRed := self class:cls protocol:cat includesModsOfClassVariable:variablesToHighlight.
- ].
- ] ifFalse:[
- doHighLight := self class:cls protocol:cat includesRefsToInstanceVariable:variablesToHighlight.
- doHighLight ifTrue:[
- doHighLightRed := self class:cls protocol:cat includesModsOfInstanceVariable:variablesToHighlight.
- ].
- ].
- doHighLight ifTrue:[
- itemsWithVarRefs add:cat.
- doHighLightRed ifTrue:[
- itemsWithVarMods add:cat.
- ].
- ]
- ]
- ].
+ variablesToHighlight notEmptyOrNil ifTrue:[
+ (itemsWithVarRefs includes:cat) ifFalse:[
+ classVarsToHighLight ifTrue:[
+ doHighLight := self class:cls protocol:cat includesRefsToClassVariable:variablesToHighlight.
+ doHighLight ifTrue:[
+ doHighLightRed := self class:cls protocol:cat includesModsOfClassVariable:variablesToHighlight.
+ ].
+ ] ifFalse:[
+ doHighLight := self class:cls protocol:cat includesRefsToInstanceVariable:variablesToHighlight.
+ doHighLight ifTrue:[
+ doHighLightRed := self class:cls protocol:cat includesModsOfInstanceVariable:variablesToHighlight.
+ ].
+ ].
+ doHighLight ifTrue:[
+ itemsWithVarRefs add:cat.
+ doHighLightRed ifTrue:[
+ itemsWithVarMods add:cat.
+ ].
+ ]
+ ]
+ ].
- AdditionalEmptyCategoriesPerClassName size > 0 ifTrue:[
- clsName := cls name.
- emptyProtocols := AdditionalEmptyCategoriesPerClassName at:clsName ifAbsent:nil.
- emptyProtocols size > 0 ifTrue:[
- emptyProtocols remove:cat ifAbsent:nil.
- ].
- emptyProtocols size == 0 ifTrue:[
- AdditionalEmptyCategoriesPerClassName removeKey:clsName ifAbsent:nil
- ].
- ].
- ]
- ]
+ AdditionalEmptyCategoriesPerClassName size > 0 ifTrue:[
+ clsName := cls name.
+ emptyProtocols := AdditionalEmptyCategoriesPerClassName at:clsName ifAbsent:nil.
+ emptyProtocols size > 0 ifTrue:[
+ emptyProtocols remove:cat ifAbsent:nil.
+ ].
+ emptyProtocols size == 0 ifTrue:[
+ AdditionalEmptyCategoriesPerClassName removeKey:clsName ifAbsent:nil
].
-
- cats := cats asSet.
+ ].
+ ]
+ ]
+ ].
- cls selectorsAndMethodsDo:[:sel :mthd |
- |info cat suppress|
+ cats := cats asSet.
+
+ cls selectorsAndMethodsDo:[:sel :mthd |
+ |info cat suppress|
- (includedCats includes:(cat := mthd category)) ifTrue:[
- suppress := packageFilter notNil
- and:[ (packageFilter includes:mthd package) not
- and:[ showChanges not ]].
- suppress ifFalse:[
- numAll := numAll + 1.
- categoryBag add:cat.
- (showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
- info := self methodInfoFor:mthd in:cls selector:sel lazy:suppressPseudoProtocolsNow.
- info notNil ifTrue:[
- info isObsolete ifTrue:[ numObsolete := numObsolete + 1 ].
- info sendsSuper ifTrue:[ numSuper := numSuper + 1 ].
- 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 isOverride ifTrue:[ numOverride := numOverride + 1 ].
- info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
- info isRedefined ifTrue:[ numRedefined := numRedefined + 1 ].
- info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
- info isAnnotated ifTrue:[ numAnnotated := numAnnotated + 1].
- ].
- (Timestamp now secondDeltaFrom:startTime) > 5 ifTrue:[
- suppressPseudoProtocolsNow := true.
- "/ because we already computed for 5 seconds, 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'.
- "/ self enqueueDelayedUpdateList.
- ].
- ]
- ]
- ].
+ (includedCats includes:(cat := mthd category)) ifTrue:[
+ suppress := packageFilter notNil
+ and:[ (packageFilter includes:mthd package) not
+ and:[ showChanges not ]].
+ suppress ifFalse:[
+ numAll := numAll + 1.
+ categoryBag add:cat.
+ (showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
+ info := self methodInfoFor:mthd in:cls selector:sel lazy:suppressPseudoProtocolsNow.
+ info notNil ifTrue:[
+ info isObsolete ifTrue:[ numObsolete := numObsolete + 1 ].
+ info sendsSuper ifTrue:[ numSuper := numSuper + 1 ].
+ 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 isOverride ifTrue:[ numOverride := numOverride + 1 ].
+ info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
+ info isRedefined ifTrue:[ numRedefined := numRedefined + 1 ].
+ info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
+ info isAnnotated ifTrue:[ numAnnotated := numAnnotated + 1].
+ ].
+ (Timestamp now secondDeltaFrom:startTime) > 5 ifTrue:[
+ suppressPseudoProtocolsNow := true.
+ "/ because we already computed for 5 seconds, 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'.
+ "/ self enqueueDelayedUpdateList.
].
]
- ].
+ ]
+ ].
+ ].
+ ]
+ ].
changeSet := ChangeSet current.
classesProcessed do:[:eachClass |
- |classPackage required|
+ |classPackage required testOutcomes|
+
+ showSyntheticMethods value ifTrue:[
+ (eachClass isMeta not and:[eachClass isTestCaseLike and:[eachClass isAbstract not]]) ifTrue:[
+ testOutcomes := eachClass testSelectorsWithLastOutcomes.
+ numAllTestResults := numAllTestResults + testOutcomes size.
+ ].
+ ].
classPackage := eachClass package.
eachClass methodDictionary keysAndValuesDo:[:mSelector :mthd |
@@ -1408,13 +1465,16 @@
(SmallTeam notNil and:[ SmallTeam includesChangeForClass:eachClass selector:mSelector] ) ifTrue:[
itemsInRemoteChangeSet add:mCategory.
].
+ testOutcomes notNil ifTrue:[ testOutcomes remove: mSelector ifAbsent:[] ].
].
(packageFilter isNil or:[ packageFilter includes:eachClass package ]) ifTrue:[
(showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
- "/ see if there is a subclassResponsibility in a superclass
- required := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:eachClass.
- numMissingRequired := numMissingRequired + required size.
+ showSyntheticMethods value ifTrue:[
+ "/ see if there is a subclassResponsibility in a superclass
+ required := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:eachClass.
+ numMissingRequired := numMissingRequired + required size.
+ ].
].
].
].
@@ -1573,6 +1633,7 @@
addPseudoEntry value:self class nameListEntryForRequired value:numMissingRequired.
addPseudoEntry value:self class nameListEntryForSuperSend value:numSuper.
addPseudoEntry value:self class nameListEntryForUncommented value:numUncommented.
+ addPseudoEntry value:self class nameListEntryForAllTests value:numAllTestResults.
showCoverageInformation ifTrue:[
addPseudoEntry value:self class nameListEntryForNotInstrumented value:numNotInstrumented.
@@ -2106,6 +2167,10 @@
"Created: / 01-04-2014 / 12:21:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+isSynthetic
+ ^ true
+!
+
who
| savedMclass |
@@ -2120,14 +2185,27 @@
"Created: / 01-04-2014 / 12:28:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
+!MethodCategoryList::MethodStubForTestResult methodsFor:'accessing'!
+
+source
+ ^ (mclass compiledMethodAt:selector) source
+ colorizeAllWith:Color grey
+! !
+
+!MethodCategoryList::MethodStubForTestResult methodsFor:'printing & storing'!
+
+printStringForBrowserWithSelector:selector inClass:aClass
+ ^ (selector,' (** from ',self mclass name,' **)') colorizeAllWith:Color gray
+! !
+
!MethodCategoryList class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools__MethodCategoryList.st,v 1.110 2015-02-21 01:02:13 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__MethodCategoryList.st,v 1.111 2015-02-26 03:58:30 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools__MethodCategoryList.st,v 1.110 2015-02-21 01:02:13 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__MethodCategoryList.st,v 1.111 2015-02-26 03:58:30 cg Exp $'
! !