hg/stx-libtool: comparison Tools_

equal deleted inserted replaced

-:0f10cd04a1fa
+:a254ee3d8a58
 BrowserList subclass:#MethodCategoryList
 	instanceVariableNames:'variableFilter filterClassVars lastSelectedProtocols classes
 		leafClasses protocolList rawProtocolList selectedProtocolIndices
 		lastGeneratedProtocols packageFilterOnInput
 		methodVisibilityHolder noAllItem noPseudoItems
-		showPseudoProtocols'
+		showPseudoProtocols showSyntheticMethods'
 	classVariableNames:'AdditionalEmptyCategoriesPerClassName MethodInfoCache
 		MethodInfoCacheAccessLock'
 	poolDictionaries:''
 	category:'Interface-Browsers-New'
 !
 	privateIn:MethodCategoryList
 !
 Method variableSubclass:#MissingMethod
 	instanceVariableNames:'selector'
+	classVariableNames:''
+	poolDictionaries:''
+	privateIn:MethodCategoryList
+!
+MethodCategoryList::MissingMethod variableSubclass:#MethodStubForTestResult
+	instanceVariableNames:''
 	classVariableNames:''
 	poolDictionaries:''
 	privateIn:MethodCategoryList
 !
 #selectionChangeCondition
 #updateTrigger
 #variableFilter
 #methodVisibilityHolder
 #showCoverageInformation
+#showSyntheticMethods
 ).
 "Modified: / 27-04-2010 / 16:40:39 / cg"
 "Modified: / 24-02-2014 / 10:37:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 showPseudoProtocols removeDependent:self
 ].
 showPseudoProtocols := aValueHolder.
 showPseudoProtocols notNil ifTrue:[
 showPseudoProtocols addDependent:self
+].
+!
+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:[
 allProtocols superSendProtocols uncommentedProtocols obsoleteProtocols
 documentationProtocols longProtocols extensionProtocols redefinedProtocols
 redefineProtocols  overrideProtocols
 missingRequiredProtocols subclassResponsibilities
 notInstrumentedProtocols annotatedProtocols fullyCoveredProtocols
-partiallyCoveredProtocols uncoveredProtocols
+partiallyCoveredProtocols uncoveredProtocols allTestsProtocols
 classSelectorPairsAlreadyDone
 packages remainingClasses remainingCategories classesAlreadyDone
 catListed showChanged|
 (leafClasses size > 0 and:[protocols size > 0]) ifTrue:[
 fullyCoveredProtocols := protocols includes:(self class nameListEntryForFullyCovered).
 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.
 ].
 showChanged := packages notNil and:[packages includes:(self class nameListEntryForChanged)].
 classesAlreadyDone := IdentitySet new.
 classSelectorPairsAlreadyDone := Set new.
 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 |
 |cat mPkg includeIt info|
 ) 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 ].
+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 ].
 includeIt := info sendsSuper ]].
 includeIt ifFalse:[
 ].
 ].
 anyInThisClass := true.
 remainingCategories remove:catListed ifAbsent:nil.
 ].
-]
+].
+allTestSelectors notNil ifTrue:[ allTestSelectors remove: sel ifAbsent:[] ].
 ].
 missingRequiredProtocols ifTrue:[
 requiredProtocolForClass := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:aClass.
 requiredProtocolForClass do:[:sel |
 |selectorInRed missingMethodPlaceHolder|
 selectorInRed := sel colorizeAllWith:Color red.
 missingMethodPlaceHolder := MissingMethod mclass:aClass selector:sel.
 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. ].
 ].
 ].
 itemsWithPartiallyCoveredMethods itemsWithFullyCoveredMethods
 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
+numAnnotated numFullyCovered numPartiallyCovered numUncovered numNotInstrumented numAllTestResults showPseudoProtocols showCoverageInformation
-showPseudoProtocols showCoverageInformation
 addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
 startTime suppressPseudoProtocolsNow needsSpecialColoring|
 userPreferences := UserPreferences current.
 countAll := true.
 variablesToHighlight := variableFilter value.
 classVarsToHighLight := filterClassVars value.
 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|
 includedCats := Set new.
 leafClassesProcessed add:clsIn.
 (self classesToProcessForClasses:(Array with:clsIn)) do:[:cls |
 |cats processCategory|
 classesProcessed add:cls.
 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.
+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.
 ].
-cats do:[:cat |
+emptyProtocols size == 0 ifTrue:[
-|suppress|
+AdditionalEmptyCategoriesPerClassName removeKey:clsName ifAbsent:nil
-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.
-].
-]
-]
-].
-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.
-(includedCats includes:(cat := mthd category)) ifTrue:[
-suppress := packageFilter notNil
+cls selectorsAndMethodsDo:[:sel :mthd |
-and:[ (packageFilter includes:mthd package) not
+|info cat suppress|
-and:[ showChanges not ]].
-suppress ifFalse:[
+(includedCats includes:(cat := mthd category)) ifTrue:[
-numAll := numAll + 1.
+suppress := packageFilter notNil
-categoryBag add:cat.
+and:[ (packageFilter includes:mthd package) not
-(showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
+and:[ showChanges not ]].
-info := self methodInfoFor:mthd in:cls selector:sel lazy:suppressPseudoProtocolsNow.
+suppress ifFalse:[
-info notNil ifTrue:[
+numAll := numAll + 1.
-info isObsolete ifTrue:[ numObsolete := numObsolete + 1 ].
+categoryBag add:cat.
-info sendsSuper ifTrue:[ numSuper := numSuper + 1 ].
+(showPseudoProtocols and:[suppressPseudoProtocolsNow not]) ifTrue:[
-info isUncommented ifTrue:[ numUncommented := numUncommented + 1 ].
+info := self methodInfoFor:mthd in:cls selector:sel lazy:suppressPseudoProtocolsNow.
-info isDocumentationMethod ifTrue:[ numDocumentation := numDocumentation + 1 ].
+info notNil ifTrue:[
-info isLongMethod ifTrue:[ numLong := numLong + 1 ].
+info isObsolete ifTrue:[ numObsolete := numObsolete + 1 ].
-info isExtensionMethod ifTrue:[ numExtension := numExtension + 1 ].
+info sendsSuper ifTrue:[ numSuper := numSuper + 1 ].
-info isOverride ifTrue:[ numOverride := numOverride + 1 ].
+info isUncommented ifTrue:[ numUncommented := numUncommented + 1 ].
-info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
+info isDocumentationMethod ifTrue:[ numDocumentation := numDocumentation + 1 ].
-info isRedefined ifTrue:[ numRedefined := numRedefined + 1 ].
+info isLongMethod ifTrue:[ numLong := numLong + 1 ].
-info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
+info isExtensionMethod ifTrue:[ numExtension := numExtension + 1 ].
-info isAnnotated ifTrue:[ numAnnotated := numAnnotated + 1].
+info isOverride ifTrue:[ numOverride := numOverride + 1 ].
-].
+info isRedefine ifTrue:[ numRedefine := numRedefine + 1 ].
-(Timestamp now secondDeltaFrom:startTime) > 5 ifTrue:[
+info isRedefined ifTrue:[ numRedefined := numRedefined + 1 ].
-suppressPseudoProtocolsNow := true.
+info isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
-"/ because we already computed for 5 seconds, more and more will be found in
+info isAnnotated ifTrue:[ numAnnotated := numAnnotated + 1].
-"/ the cache, and eventually, pseudo protocols will be shown anyway
+].
-masterApplication showInfo:'suppress pseudo protocols - parsing took too long'.
+(Timestamp now secondDeltaFrom:startTime) > 5 ifTrue:[
-"/ self enqueueDelayedUpdateList.
+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 |
 |mPackage mCategory|
 ]
 ].
 (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
+showSyntheticMethods value ifTrue:[
-required := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:eachClass.
+"/ see if there is a subclassResponsibility in a superclass
-numMissingRequired := numMissingRequired + required size.
+required := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:eachClass.
+numMissingRequired := numMissingRequired + required size.
+].
 ].
 ].
 ].
 pseudoEntryColor := self class pseudoEntryForegroundColor.
 "/            rawProtocolList add:self class nameListEntryForRequired.
 "/        ].
 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.
 addPseudoEntryWithColor value:self class nameListEntryForUncovered value:numUncovered value:userPreferences colorForInstrumentedNeverCalledCode.
 addPseudoEntryWithColor value:self class nameListEntryForPartiallyCovered value:numPartiallyCovered value:userPreferences colorForInstrumentedPartiallyCoveredCode.
 ].
 "Created: / 01-04-2014 / 12:21:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
+isSynthetic
+^ true
+!
 who
 | savedMclass |
 "/ Save mclass here as Method>>who clobbers it!!
 [
 ].
 "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 $'
 ! !
 MethodCategoryList initialize!
 MethodCategoryList::CachedMethodInfo initialize!

changeset 15436	a254ee3d8a58
parent 15347	8397336f18b3
child 15566	184cea584be5
child 15648	629594de3115