--- a/Tools_MethodCategoryList.st Mon Aug 08 18:23:04 2011 +0200
+++ b/Tools_MethodCategoryList.st Mon Aug 08 18:27:03 2011 +0200
@@ -1120,10 +1120,13 @@
numRedefine numExtension numMissingRequired numSubclassResponsibility
numFullyCovered numPartiallyCovered numUncovered numNotInstrumented
showPseudoProtocols showCoverageInformation
- addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences|
+ addPseudoEntry addPseudoEntryWithColor countAll pseudoEntryColor userPreferences
+ startTime lazyPseudoProtocols|
userPreferences := UserPreferences current.
countAll := true.
+ startTime := Timestamp now.
+ lazyPseudoProtocols := false.
generator := inGeneratorHolder value.
generator isNil ifTrue:[ ^ #() ].
@@ -1208,23 +1211,28 @@
]
].
- showPseudoProtocols value ifTrue:[
+ (showPseudoProtocols value) ifTrue:[
cls selectorsAndMethodsDo:[:sel :mthd |
|info|
mthd category = cat ifTrue:[
- info := self methodInfoFor:mthd in:cls selector:sel.
- 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 isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
+ info := self methodInfoFor:mthd in:cls selector:sel lazy:lazyPseudoProtocols.
+ 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 isSubclassResponsibility ifTrue:[ numSubclassResponsibility := numSubclassResponsibility + 1].
+ ]
]
].
+ (Timestamp now deltaFrom:startTime) > 10 seconds ifTrue:[
+ lazyPseudoProtocols := true.
+ ].
].
categoryList add:cat.
@@ -1307,7 +1315,7 @@
].
].
].
- showPseudoProtocols value ifTrue:[
+ (lazyPseudoProtocols not and:[showPseudoProtocols value]) ifTrue:[
"/ see if there is a subclassResponsibility in a superclass
required := SmalltalkCodeGeneratorTool missingRequiredProtocolFor:eachClass.
numMissingRequired := numMissingRequired + required size.
@@ -1431,7 +1439,7 @@
].
].
- showPseudoProtocols value ifTrue:[
+ (lazyPseudoProtocols not and:[showPseudoProtocols value]) ifTrue:[
addPseudoEntryWithColor := [:s :n :clr |
n > 0 ifTrue:[
categoryList
@@ -1468,7 +1476,7 @@
^ categoryList
"Created: / 05-02-2000 / 13:42:11 / cg"
- "Modified: / 20-07-2011 / 18:41:25 / cg"
+ "Modified: / 08-08-2011 / 18:19:54 / cg"
!
makeDependent
@@ -1555,46 +1563,61 @@
!MethodCategoryList methodsFor:'private-info'!
methodInfoFor:aMethod in:mclass selector:selector
+ ^ self methodInfoFor:aMethod in:mclass selector:selector lazy:false
+
+ "Modified: / 08-08-2011 / 18:21:03 / cg"
+!
+
+methodInfoFor:aMethod in:mclass selector:selector lazy:lazy
|info isDocumentationMethod isVersionMethod def|
"/ 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
- info := MethodInfoCache at:(mclass name,'>>',selector) ifAbsent:nil.
+ MethodInfoCacheAccessLock critical:[
+ info := MethodInfoCache at:(mclass name,'>>',selector) ifAbsent:nil.
+ ].
info isNil ifTrue:[
- true "aMethod mclass language isSmalltalk" ifTrue:[
- info := CachedMethodInfo new.
- info isObsolete:(aMethod isObsolete).
- info sendsSuper:(aMethod superMessages notEmptyOrNil).
- info isUncommented:(self methodIsMarkedAsUncommented:aMethod).
- isVersionMethod := aMethod isVersionMethod.
- isDocumentationMethod := isVersionMethod not and:[aMethod isDocumentationMethod].
- info isDocumentationMethod:isDocumentationMethod.
- info isLongMethod:( self methodIsMarkedAsLong:aMethod ).
+ 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.
+ info isObsolete:(aMethod isObsolete).
+ info sendsSuper:(aMethod superMessages notEmptyOrNil).
+ info isUncommented:(self methodIsMarkedAsUncommented:aMethod).
+ isVersionMethod := aMethod isVersionMethod.
+ isDocumentationMethod := isVersionMethod not and:[aMethod isDocumentationMethod].
+ info isDocumentationMethod:isDocumentationMethod.
+ info isLongMethod:( self methodIsMarkedAsLong:aMethod ).
- aMethod package ~= mclass package ifTrue:[
- aMethod package ~= #'__NoProject__' ifTrue:[
- info isExtensionMethod:true.
- info isOverride:( (def := aMethod package 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 ]]]).
+ aMethod package ~= mclass package ifTrue:[
+ aMethod package ~= #'__NoProject__' ifTrue:[
+ info isExtensionMethod:true.
+ info isOverride:( (def := aMethod package 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 isSubclassResponsibility:( aMethod sends:#subclassResponsibility or:#subclassResponsibility: ).
+ info isSubclassResponsibility:( aMethod sends:#subclassResponsibility or:#subclassResponsibility: ).
- MethodInfoCacheAccessLock critical:[
- MethodInfoCache at:(mclass name,'>>',selector) put:info
+ MethodInfoCacheAccessLock critical:[
+ MethodInfoCache at:(mclass name,'>>',selector) put:info
+ ].
].
].
].
^ info
+
+ "Created: / 08-08-2011 / 18:18:14 / cg"
!
methodIsMarkedAsLong:aMethod
@@ -1893,11 +1916,11 @@
!MethodCategoryList class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.67 2011-07-20 18:19:06 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.68 2011-08-08 16:27:03 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.67 2011-07-20 18:19:06 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.68 2011-08-08 16:27:03 cg Exp $'
! !
MethodCategoryList initialize!