"

 COPYRIGHT (c) 2004 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libtool' }"

"{ NameSpace: Tools }"

Object subclass:#ClassChecker

	instanceVariableNames:'checkedClass badClasses badClassInfo badMethods badMethodInfo

		obsoleteWarners allObsoleteMethods checksPerformed'

	classVariableNames:''

	poolDictionaries:''

	category:'Interface-Browsers-New'

!

!ClassChecker class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2004 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    embeddable application displaying the class-categories.

    Provides an outputGenerator, which enumerates the classes in

    the selected categories.

    Attention: do not change the method categories 'checks-' into something else.

    The 'checks-' prefix is used to detect checks and these are listed in the browsers

    lint dialog.

    [author:]

        Claus Gittinger (cg@exept.de)

"

! !

!ClassChecker class methodsFor:'queries'!

individualChecks

    "return a list of supported checks"

    |checks|

    checks := OrderedCollection new.

    self methodDictionary keysAndValuesDo:[:sel :mthd |

	(mthd category startsWith:'checks')  ifTrue:[checks add:sel]

    ].

    checks sort.

    ^ checks

    "

     self individualChecks

    "

    "Created: / 18.8.2000 / 22:30:46 / cg"

    "Modified: / 18.8.2000 / 22:31:02 / cg"

! !

!ClassChecker methodsFor:'accessing'!

badClassInfo

    ^ badClassInfo

!

badMethodInfo

    ^ badMethodInfo

!

checkedClass

    "return the value of the instance variable 'checkedClass' (automatically generated)"

    ^ checkedClass

!

checkedClass:something

    "set the value of the instance variable 'checkedClass' (automatically generated)"

    checkedClass := something.

    checksPerformed := nil.

! !

!ClassChecker methodsFor:'checking'!

allChecks

    self errorChecks.

    self warningChecks.

    self styleChecks.

!

doCheck:whichCheck

    checksPerformed isNil ifTrue:[

	checksPerformed := Set new.

    ].

    (checksPerformed includes:whichCheck) ifFalse:[

	checksPerformed add:whichCheck.

	self perform:whichCheck

    ]

!

errorChecks

    self doCheck:#subclassResponsibilityNotDefined.

    self doCheck:#sentNotImplemented.

    self doCheck:#definesEqualButNotHash.

    self doCheck:#instanceVariablesNeverWritten.

!

styleChecks

    self doCheck:#checkProtocols.

    self doCheck:#sendsObsoleteMethodWarningButNotTaggedAsObsoleteOrViceVersa.

"/    self doCheck:#guardingClause.

!

warningChecks

    self doCheck:#messageNeverSentAndNotUsedAsSymbol.

    self doCheck:#sendsObsoleteMessages.

    self doCheck:#instanceVariablesNeverUsed.

    self doCheck:#instanceVariablesNeverWritten.

    self doCheck:#classVariablesNeverUsed.

    self doCheck:#classVariablesNeverWritten.

    self doCheck:#classInstanceVariablesNeverUsed.

    self doCheck:#classInstanceVariablesNeverWritten.

    self doCheck:#invalidKeyInImageResourceMethod

! !

!ClassChecker methodsFor:'checks-individual'!

checkProtocols

    checkedClass instAndClassSelectorsAndMethodsDo:[:mSelector :method |

	self checkProtocolOf:method

    ]

!

checkVariableNameConventions

    |badInstVars badClassVars|

    badInstVars := checkedClass instanceVariableNames select:[:varName | varName isUppercaseFirst].

    badClassVars := checkedClass classVarNames select:[:varName | varName first isLowercase].

    badInstVars notEmpty ifTrue:[

        badInstVars := (badInstVars collect:[:v | '''' , v , '''']) asStringWith:$, .

        self 

            rememberBadClass:checkedClass

            info:('instVars ' , badInstVars , ' should be lowercase (#checkNameConventions)').

    ].

    badClassVars notEmpty ifTrue:[

        badClassVars := (badClassVars collect:[:v | '''' , v , '''']) asStringWith:$, .

        self 

            rememberBadClass:checkedClass

            info:('classVars ' , badClassVars , ' should be uppercase (#checkNameConventions)').

    ].

!

classInstanceVariablesNeverUsed

    self instanceVariablesNeverUsedIn:checkedClass theMetaclass.

!

classInstanceVariablesNeverWritten

    self instanceVariablesNeverWrittenIn:checkedClass theMetaclass.

!

classVariablesNeverUsed

    |cls notUsedHere notUsedAnyWhere anySubclass|

    cls := checkedClass theNonMetaclass.

    notUsedHere := cls classVarNames asSet.

    notUsedHere isEmpty ifTrue:[^ self].

    self removeUsedClassVariablesIn:cls from:notUsedHere.

    self removeUsedClassVariablesIn:cls class from:notUsedHere.

    notUsedHere notEmpty ifTrue:[

	notUsedAnyWhere := notUsedHere copy.

	anySubclass := false.

	cls allSubclassesDo:[:eachSubclass |

	    anySubclass := true.

	    notUsedAnyWhere notEmpty ifTrue:[

		self removeUsedClassVariablesIn:eachSubclass from:notUsedAnyWhere.

		self removeUsedClassVariablesIn:eachSubclass class from:notUsedAnyWhere.

	    ]

	].

	notUsedHere do:[:eachVariable |

	    |className|

	    className := checkedClass name allBold.

	    self 

		rememberBadClass:cls

		info:('classVar ' , eachVariable allBold , ' is unused in ' , className , ' (#classVariablesNeverUsed)').

	    (notUsedAnyWhere includes:eachVariable) ifTrue:[

		self 

		    rememberBadClass:cls

		    info:('classVar ' , eachVariable allBold , ' is not even used in subclasses of ' , className , ' (#classVariablesNeverUsed)')

	    ]

	].

    ]

!

classVariablesNeverWritten

    |cls notWrittenHere notWrittenAnyWhere anySubclass|

    cls := checkedClass theNonMetaclass.

    notWrittenHere := cls classVarNames asSet.

    notWrittenHere isEmpty ifTrue:[^ self].

    self removeWrittenClassVariablesIn:cls from:notWrittenHere.

    self removeWrittenClassVariablesIn:cls class from:notWrittenHere.

    notWrittenHere notEmpty ifTrue:[

	notWrittenAnyWhere := notWrittenHere copy.

	anySubclass := false.

	cls allSubclassesDo:[:eachSubclass |

	    anySubclass := true.

	    notWrittenAnyWhere notEmpty ifTrue:[

		self removeWrittenClassVariablesIn:eachSubclass from:notWrittenAnyWhere.

		self removeWrittenClassVariablesIn:eachSubclass class from:notWrittenAnyWhere.

	    ]

	].

	notWrittenHere do:[:eachVariable |

	    |className|

	    className := cls name allBold.

	    self 

		rememberBadClass:cls

		info:('classVar ' , eachVariable allBold , ' is not set in ' , className , ' (#classVariablesNeverWritten)').

	    (notWrittenAnyWhere includes:eachVariable) ifTrue:[

		self 

		    rememberBadClass:cls

		    info:('classVar ' , eachVariable allBold , ' is not even set in subclasses of ' , className , ' (#classVariablesNeverWritten)')

	    ]

	].

    ]

!

definesEqualButNotHash

    (checkedClass includesSelector:#=) ifTrue:[

	(checkedClass includesSelector:#hash) ifFalse:[

	    self 

		rememberBadClass:checkedClass 

		info:(checkedClass name allBold, ' redefines #=, but not #hash (#definesEqualButNotHash)').

	]

    ]

!

guardingClause

    |detector|

    detector := ParseTreeLintRule guardingClause.

    detector runOnEnvironment: (Array with:checkedClass).

self breakPoint:#cg.

!

instanceVariablesNeverUsed

    self instanceVariablesNeverUsedIn:checkedClass theNonMetaclass.

!

instanceVariablesNeverWritten

    self instanceVariablesNeverWrittenIn:checkedClass theNonMetaclass.

!

invalidKeyInImageResourceMethod

    Icon flushCachedIcons.

    checkedClass instAndClassSelectorsAndMethodsDo:[:sel :mthd | 

        |img key name|

        (mthd hasImageResource) ifTrue:[

           img := mthd valueWithReceiver:nil arguments:#().

           key := (Icon classVarAt:#KnownIcons) keyAtIdentityValue:img.

           key notNil ifTrue:[

              mthd mclass notNil ifTrue:[  

                  name := (mthd mclass name , ' ', mthd selector).

                  name ~= key ifTrue:[

                      self 

                          rememberBadMethod:mthd 

                          key:#invalidKeyInImageResourceMethod

                          info:('key in constantNamed: does not match the method name')

                  ]

              ]

           ]

        ]

    ].

!

messageNeverSent

    "/ old code: (slow)

"/    checkedClass instAndClassSelectorsAndMethodsDo:[:mSelector :method |

"/        (self anySendsOf:mSelector) ifFalse:[

"/            self 

"/                rememberBadMethod:method 

"/                info:('#' , mSelector , ' is nowhere sent (#messageNeverSent)')

"/        ].

"/    ].

    |selectorsOfInterest|

    selectorsOfInterest := IdentitySet new.

    checkedClass instAndClassSelectorsAndMethodsDo:[:mSelector :method |  selectorsOfInterest add:mSelector].

    (self messagesNeverSentIn:selectorsOfInterest) do:[:eachNeverSent |

	self 

	    rememberBadMethod:(checkedClass compiledMethodAt:eachNeverSent) 

	    key:#messageNeverSent

	    info:('#' , eachNeverSent allBold, ' is nowhere sent (#messageNeverSent)')

    ].

    "Modified: / 18.8.2000 / 22:54:45 / cg"

!

messageNeverSentAndNotUsedAsSymbol

    |selectorsOfInterest|

    selectorsOfInterest := IdentitySet new.

    checkedClass instAndClassSelectorsAndMethodsDo:[:mSelector :method |  selectorsOfInterest add:mSelector].

    (self messagesNeverSentAndNotUsedAsSymbolIn:selectorsOfInterest) do:[:eachNeverSent |

	self 

	    rememberBadMethod:(checkedClass compiledMethodAt:eachNeverSent) 

	    key:#messageNeverSentAndNotUsedAsSymbol

	    info:('#' , eachNeverSent allBold, ' is nowhere sent and selector-symbol not used in any method (#messageNeverSentAndNotUsedAsSymbol)')

    ].

    "Modified: / 18.8.2000 / 23:10:56 / cg"

!

sendsObsoleteMessages

    obsoleteWarners isNil ifTrue:[

        obsoleteWarners := Object selectors select:[:each | each startsWith:'obsoleteMethodWarning'].

    ].

    allObsoleteMethods isNil ifTrue:[

        allObsoleteMethods := IdentitySet new.

        Method allSubInstancesDo:[:eachMethod | |lits selector|

                ((lits := eachMethod literals) notNil

                and:[lits includesAny:obsoleteWarners]) ifTrue:[

                     (eachMethod messagesSent includesAny:obsoleteWarners) ifTrue:[

                        selector := eachMethod selector.

                        selector notNil ifTrue:[

                            allObsoleteMethods add:selector.

                        ]

                    ].

                ].

            ].

        "/ manually patchup; there are some which should not be considered as bad ...

        allObsoleteMethods removeAllFoundIn:#( #','  #'at:'  #'at:put:'  #'raise').

        allObsoleteMethods removeAllFoundIn:#( #'asText').

        allObsoleteMethods removeAllFoundIn:obsoleteWarners.

    ].

    checkedClass instAndClassSelectorsAndMethodsDo:[:sel :mthd | 

        |lits sentMessages whichOnes pT searcher nodes|

        ((lits := mthd literals) notNil

        and:[lits includesAny:allObsoleteMethods]) ifTrue:[

            sentMessages := mthd messagesSent.

            (sentMessages includesAny:allObsoleteMethods) ifTrue:[

                whichOnes := sentMessages select:[:each | allObsoleteMethods includes:each].

                (RBParser notNil

                and:[RBParser isLoaded]) ifTrue:[

                    "/ lets look at this a bit more detailed;

                    "/ parse it and see if we can filter out any messages 

                    "/ (i.e. look if we can figure out the receiver type)

"/                    pT := RBParser 

"/                            parseMethod: (mthd source)

"/                            onError: [:aString :pos | nil].

"/                    pT notNil ifTrue:[

"/                        searcher := ParseTreeSearcher 

"/                                        allMessageSendsMatchingAny:whichOnes ignoreCase:false.

"/                        nodes := searcher executeTree:pT initialAnswer:(OrderedCollection new).

"/                        nodes := nodes 

"/                            select:

"/                                [:aSendNode |

"/                                    self halt.

"/                                ].

"/                        whichOnes := nodes collect:[:aSendNode | aSendNode selector].

"/                    ].

                ].

                whichOnes asOrderedCollection sort do:[:eachObsoleteMessage |

                    self 

                        rememberBadMethod:mthd 

                        key:#sendsObsoleteMessages

                        info:('possibly sends an obsolete message: ' , eachObsoleteMessage , ' (#sendsObsoleteMessages)')

                ].

            ].

        ]

    ]

!

sendsObsoleteMethodWarningButNotTaggedAsObsoleteOrViceVersa

    |obsoleteWarners|

    obsoleteWarners := #( #'obsoleteMethodWarning' #'obsoleteMethodWarning:' ).

    checkedClass instAndClassSelectorsAndMethodsDo:[:sel :mthd | 

        |lits sentMessages whichOnes pT searcher nodes|

        ((lits := mthd literals) notNil

        and:[lits includesAny:obsoleteWarners]) ifTrue:[

            mthd isObsolete ifFalse:[

                self 

                    rememberBadMethod:mthd 

                    key:#sendsObsoleteMethodWarningButNotTaggedAsObsoleteOrViceVersa

                    info:('sends obsoleteMethodWarning but not tagged as obsolete')

            ].

        ] ifFalse:[

            mthd isObsolete ifTrue:[

                self 

                    rememberBadMethod:mthd 

                    key:#sendsObsoleteMethodWarningButNotTaggedAsObsoleteOrViceVersa

                    info:('tagged as obsolete but does not send an obsoleteMethodWarning')

            ].

        ].

    ]

!

sentNotImplemented

    |alreadyChecked alreadyCheckedSelf alreadyCheckedSuper|

    alreadyChecked := IdentitySet new.

    alreadyCheckedSelf := IdentitySet new.

    alreadyCheckedSuper := IdentitySet new.

    checkedClass methodDictionary keysAndValuesDo:[:mSelector :method |

	|sentSelectors selfSelectors superSelectors selectorsNoWhereImplemented|

	selectorsNoWhereImplemented := IdentitySet new.

	sentSelectors := method messagesSent.

	sentSelectors do:[:eachSelector |

	    (alreadyChecked includes:eachSelector) ifFalse:[

		(self anyImplementationOf:eachSelector) ifTrue:[

		    alreadyChecked add:eachSelector

		] ifFalse:[

		    selectorsNoWhereImplemented add:eachSelector.

		    self 

			rememberBadMethod:method 

			key:#sentNotImplemented

			info:('#' , eachSelector allBold, ' is nowhere implemented (#sentNotImplemented)')

		]

	    ]

	].

	selfSelectors := method messagesSentToSelf.

	selfSelectors do:[:eachSelector |

	    (selectorsNoWhereImplemented includes:eachSelector) ifFalse:[

		(alreadyCheckedSelf includes:eachSelector) ifFalse:[

		    (self anyImplementationOf:eachSelector inOrAbove:checkedClass) ifTrue:[

			alreadyCheckedSelf add:eachSelector

		    ] ifFalse:[            

			self 

			    rememberBadMethod:method 

			    key:#sentNotImplemented

			    info:('#' , eachSelector allBold, ' is not implemented in the class (#sentNotImplemented)')

		    ]

		]

	    ]

	].

	superSelectors := method messagesSentToSuper.

	superSelectors do:[:eachSelector |

	    (selectorsNoWhereImplemented includes:eachSelector) ifFalse:[

		(alreadyCheckedSuper includes:eachSelector) ifFalse:[

		    (self anyImplementationOf:eachSelector inOrAbove:(checkedClass superclass)) ifTrue:[

			alreadyCheckedSuper add:eachSelector

		    ] ifFalse:[            

			self 

			    rememberBadMethod:method 

			    key:#sentNotImplemented

			    info:('#' , eachSelector allBold, ' is not implemented in any superclass (#sentNotImplemented)')

		    ]

		]

	    ]

	].

    ].

!

subclassResponsibilityNotDefined

    |classesInBetween|

    checkedClass allSuperclasses do:[:eachSuperClass |

	eachSuperClass methodDictionary keysAndValuesDo:[:mSelector :method |

	    (method referencesLiteral:#subclassResponsibility) ifTrue:[

		"/ parse it to see if it really does ...

		(method sends:#subclassResponsibility) ifTrue:[

		    "/ ok, got one;

		    "/ now, see if it is defined below this superClass

		    classesInBetween := checkedClass withAllSuperclasses copy.

		    classesInBetween removeAll:(eachSuperClass withAllSuperclasses).

		    (self anyImplementationOf:mSelector in:classesInBetween) ifFalse:[

			(self methodShouldBeIgnoredInSubclassResponsibilityNotDefined:method)

			ifFalse:[

			    self 

				rememberBadMethod:method 

				key:#subclassResponsibilityNotDefined