--- a/Tools_MethodCategoryList.st Wed Oct 14 16:07:02 2009 +0200
+++ b/Tools_MethodCategoryList.st Wed Oct 14 16:51:29 2009 +0200
@@ -867,35 +867,35 @@
includeIt ifFalse:[ includeIt := protocols includes:cat ].
includeIt ifFalse:[
superSendProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ 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 ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isUncommented ]].
includeIt ifFalse:[
obsoleteProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isObsolete ]].
includeIt ifFalse:[
documentationProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isDocumentationMethod ]].
includeIt ifFalse:[
longProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ 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 ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isExtensionMethod ]].
includeIt ifFalse:[
overrideProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isOverride ]].
includeIt ifFalse:[
redefinedProtocols ifTrue:[
- info isNil ifTrue:[ info := self methodInfoFor:mthd ].
+ info isNil ifTrue:[ info := self methodInfoFor:mthd in:aClass selector:sel ].
includeIt := info isRedefine ]].
includeIt ifTrue:[
@@ -1111,7 +1111,7 @@
|info|
mthd category = cat ifTrue:[
- info := self methodInfoFor:mthd.
+ 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 ].
@@ -1309,39 +1309,39 @@
"/ ChangeSet removeDependent:self.
!
-methodInfoFor:aMethod
- |info mclass selector|
-
- mclass := aMethod mclass.
- selector := aMethod selector.
+methodInfoFor:aMethod in:mclass selector:selector
+ |info|
- MethodInfoCacheAccessLock critical:[
- info := MethodInfoCache
- at:(mclass name,'>>',selector)
- ifAbsentPut:[
- |info|
+ "/ 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.
+ 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).
+ info isDocumentationMethod:( aMethod isDocumentationMethod).
+ info isLongMethod:( self methodIsMarkedAsLong:aMethod ).
- true "aMethod mclass language isSmalltalk" ifTrue:[
- info := CachedMethodInfo new.
- info isObsolete:(aMethod isObsolete).
- info sendsSuper:(aMethod superMessages notEmptyOrNil).
- info isUncommented:(aMethod comment isEmptyOrNil and:[aMethod isVersionMethod not]).
- info isDocumentationMethod:( aMethod isDocumentationMethod).
- info isLongMethod:( aMethod source asCollectionOfLines size > UserPreferences current numberOfLinesForLongMethod ).
- aMethod package ~= mclass package ifTrue:[
- aMethod package ~= #'__NoProject__' ifTrue:[
- info isExtensionMethod:true.
- info isOverride:( aMethod package asPackageId projectDefinitionClass
- methodOverwrittenBy:aMethod ) notNil
- ]
- ] ifFalse:[
- info isExtensionMethod:false.
- info isOverride:false.
- ].
- info isRedefine:( mclass superclass whichClassIncludesSelector:selector ) notNil.
- ].
- info
- ]
+ aMethod package ~= mclass package ifTrue:[
+ aMethod package ~= #'__NoProject__' ifTrue:[
+ info isExtensionMethod:true.
+ info isOverride:( aMethod package asPackageId projectDefinitionClass
+ methodOverwrittenBy:aMethod ) notNil
+ ]
+ ] ifFalse:[
+ info isExtensionMethod:false.
+ info isOverride:false.
+ ].
+ info isRedefine:( mclass superclass notNil
+ and:[ (mclass superclass whichClassIncludesSelector:selector ) notNil ]).
+
+ MethodInfoCacheAccessLock critical:[
+ MethodInfoCache at:(mclass name,'>>',selector) put:info
+ ].
+ ].
].
^ info
!
@@ -1415,6 +1415,43 @@
"Modified: / 29.2.2000 / 11:08:55 / cg"
! !
+!MethodCategoryList methodsFor:'private-info'!
+
+methodIsMarkedAsLong:aMethod
+ "if true, it will be also categorized under the pseudo category 'long'"
+
+ |src ast linesWithCode visitor|
+
+ src := aMethod source.
+ src asCollectionOfLines size < UserPreferences current numberOfLinesForLongMethod "~~30" ifTrue:[^ false].
+
+ "/ ok, it is long;
+ "/ but do not blame the user for writing documentation (dont count comments),
+ "/ or using literal arrays
+ RBParser notNil ifTrue:[
+ ast := RBParser parseMethod:src.
+ visitor := RBProgramNodeVisitor new.
+ visitor pluggableNodeAction:
+ [:eachNode |
+ |lno|
+ lno := eachNode lineNumber.
+ lno notNil ifTrue:[ linesWithCode add:lno ].
+ ].
+
+ linesWithCode := Set new.
+ ast acceptVisitor:visitor.
+ linesWithCode size < UserPreferences current numberOfLinesForLongMethod "~~30" ifTrue:[^ false].
+ ].
+ ^ true.
+!
+
+methodIsMarkedAsUncommented:aMethod
+ "if true, it will be also categorized under the pseudo category 'undocumented'"
+
+ ^ aMethod comment isEmptyOrNil
+ and:[aMethod isVersionMethod not]
+! !
+
!MethodCategoryList methodsFor:'special'!
addAdditionalProtocol:aProtocol forClass:aClass
@@ -1611,11 +1648,11 @@
!MethodCategoryList class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.39 2009-10-14 10:10:22 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.40 2009-10-14 14:51:29 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.39 2009-10-14 10:10:22 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.40 2009-10-14 14:51:29 cg Exp $'
! !
MethodCategoryList initialize!