# HG changeset patch # User Claus Gittinger # Date 1256838970 -3600 # Node ID 26fb27aa3d4046e307dfdf049a0057f45ff87517 # Parent 02f8167944f8bdcacfbe9b2b95c8e1042dd0e719 changed: #listOfMethodCategories diff -r 02f8167944f8 -r 26fb27aa3d40 Tools_MethodCategoryList.st --- a/Tools_MethodCategoryList.st Thu Oct 29 18:55:01 2009 +0100 +++ b/Tools_MethodCategoryList.st Thu Oct 29 18:56:10 2009 +0100 @@ -1,6 +1,6 @@ " COPYRIGHT (c) 2000 by eXept Software AG - All Rights Reserved + 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 @@ -14,31 +14,31 @@ "{ NameSpace: Tools }" BrowserList subclass:#MethodCategoryList - instanceVariableNames:'variableFilter filterClassVars lastSelectedProtocols classes - leafClasses protocolList rawProtocolList selectedProtocolIndices - lastGeneratedProtocols packageFilterOnInput - methodVisibilityHolder noAllItem noPseudoItems - showPseudoProtocols' - classVariableNames:'AdditionalEmptyCategoriesPerClassName MethodInfoCache - MethodInfoCacheAccessLock' - poolDictionaries:'' - category:'Interface-Browsers-New' + instanceVariableNames:'variableFilter filterClassVars lastSelectedProtocols classes + leafClasses protocolList rawProtocolList selectedProtocolIndices + lastGeneratedProtocols packageFilterOnInput + methodVisibilityHolder noAllItem noPseudoItems + showPseudoProtocols' + classVariableNames:'AdditionalEmptyCategoriesPerClassName MethodInfoCache + MethodInfoCacheAccessLock' + poolDictionaries:'' + category:'Interface-Browsers-New' ! Object subclass:#CachedMethodInfo - instanceVariableNames:'flags' - classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented - FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension - FlagIsRedefine FlagIsOverride FlagIsSubclassResponsibility' - poolDictionaries:'' - privateIn:MethodCategoryList + instanceVariableNames:'flags' + classVariableNames:'FlagObsolete FlagSendsSuper FlagIsUncommented + FlagIsDocumentationMethod FlagIsLongMethod FlagIsExtension + FlagIsRedefine FlagIsOverride FlagIsSubclassResponsibility' + poolDictionaries:'' + privateIn:MethodCategoryList ! Method variableSubclass:#MissingMethod - instanceVariableNames:'selector' - classVariableNames:'' - poolDictionaries:'' - privateIn:MethodCategoryList + instanceVariableNames:'selector' + classVariableNames:'' + poolDictionaries:'' + privateIn:MethodCategoryList ! !MethodCategoryList class methodsFor:'documentation'! @@ -46,7 +46,7 @@ copyright " COPYRIGHT (c) 2000 by eXept Software AG - All Rights Reserved + 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 @@ -90,29 +90,29 @@ ^ #(#FullSpec - #name: #singleProtocolWindowSpec - #window: + #name: #singleProtocolWindowSpec + #window: #(#WindowSpec - #label: 'ProtocolList' - #name: 'ProtocolList' - #min: #(#Point 0 0) - #max: #(#Point 1024 721) - #bounds: #(#Rectangle 12 22 312 322) - ) - #component: + #label: 'ProtocolList' + #name: 'ProtocolList' + #min: #(#Point 0 0) + #max: #(#Point 1024 721) + #bounds: #(#Rectangle 12 22 312 322) + ) + #component: #(#SpecCollection - #collection: #( - #(#LabelSpec - #label: 'ProtocolName' - #name: 'ProtocolLabel' - #layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0) - #translateLabel: true - #labelChannel: #protocolLabelHolder - #menu: #menuHolder - ) - ) + #collection: #( + #(#LabelSpec + #label: 'ProtocolName' + #name: 'ProtocolLabel' + #layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0) + #translateLabel: true + #labelChannel: #protocolLabelHolder + #menu: #menuHolder + ) + ) - ) + ) ) ! @@ -218,8 +218,8 @@ filterClassVars filterClassVars isNil ifTrue:[ - filterClassVars := false asValue. - filterClassVars addDependent:self + filterClassVars := false asValue. + filterClassVars addDependent:self ]. ^ filterClassVars @@ -229,11 +229,11 @@ filterClassVars:aValueHolder filterClassVars notNil ifTrue:[ - filterClassVars removeDependent:self + filterClassVars removeDependent:self ]. filterClassVars := aValueHolder. filterClassVars notNil ifTrue:[ - filterClassVars addDependent:self + filterClassVars addDependent:self ]. "Modified: / 31.1.2000 / 00:56:31 / cg" @@ -242,19 +242,19 @@ methodVisibilityHolder methodVisibilityHolder isNil ifTrue:[ - methodVisibilityHolder := false asValue. - methodVisibilityHolder addDependent:self + methodVisibilityHolder := false asValue. + methodVisibilityHolder addDependent:self ]. ^ methodVisibilityHolder ! methodVisibilityHolder:aValueHolder methodVisibilityHolder notNil ifTrue:[ - methodVisibilityHolder removeDependent:self + methodVisibilityHolder removeDependent:self ]. methodVisibilityHolder := aValueHolder. methodVisibilityHolder notNil ifTrue:[ - methodVisibilityHolder addDependent:self + methodVisibilityHolder addDependent:self ]. "Modified: / 31.1.2000 / 00:56:31 / cg" @@ -263,26 +263,26 @@ noAllItem noAllItem isNil ifTrue:[ - noAllItem := false asValue. - noAllItem addDependent:self + noAllItem := false asValue. + noAllItem addDependent:self ]. ^ noAllItem ! noAllItem:aValueHolder noAllItem notNil ifTrue:[ - noAllItem removeDependent:self + noAllItem removeDependent:self ]. noAllItem := aValueHolder. noAllItem notNil ifTrue:[ - noAllItem addDependent:self + noAllItem addDependent:self ]. ! packageFilterOnInput packageFilterOnInput isNil ifTrue:[ - packageFilterOnInput := nil asValue. - packageFilterOnInput addDependent:self + packageFilterOnInput := nil asValue. + packageFilterOnInput addDependent:self ]. ^ packageFilterOnInput ! @@ -292,14 +292,14 @@ prevFilter := packageFilterOnInput value. packageFilterOnInput notNil ifTrue:[ - packageFilterOnInput removeDependent:self + packageFilterOnInput removeDependent:self ]. packageFilterOnInput := aValueHolder. packageFilterOnInput notNil ifTrue:[ - packageFilterOnInput addDependent:self + packageFilterOnInput addDependent:self ]. prevFilter ~= packageFilterOnInput value ifTrue:[ - self enqueueDelayedUpdateList + self enqueueDelayedUpdateList ]. ! @@ -309,7 +309,7 @@ protocolList protocolList isNil ifTrue:[ - protocolList := List new. "/ ValueHolder new + protocolList := List new. "/ ValueHolder new ]. ^ protocolList @@ -319,15 +319,15 @@ rawProtocolList rawProtocolList isNil ifTrue:[ - rawProtocolList := List new. + rawProtocolList := List new. ]. ^ rawProtocolList ! selectedProtocolIndices selectedProtocolIndices isNil ifTrue:[ - selectedProtocolIndices := ValueHolder new. - selectedProtocolIndices addDependent:self + selectedProtocolIndices := ValueHolder new. + selectedProtocolIndices addDependent:self ]. ^ selectedProtocolIndices. ! @@ -360,8 +360,8 @@ variableFilter variableFilter isNil ifTrue:[ - variableFilter := false asValue. - variableFilter addDependent:self + variableFilter := false asValue. + variableFilter addDependent:self ]. ^ variableFilter @@ -371,11 +371,11 @@ variableFilter:aValueHolder variableFilter notNil ifTrue:[ - variableFilter removeDependent:self + variableFilter removeDependent:self ]. variableFilter := aValueHolder. variableFilter notNil ifTrue:[ - variableFilter addDependent:self + variableFilter addDependent:self ]. "Modified: / 31.1.2000 / 00:56:31 / cg" @@ -389,30 +389,30 @@ anyChange := false. refetch := [:oldClass | - |nm cls newClass| + |nm cls newClass| - nm := oldClass theNonMetaclass name. - oldClass isMeta ifTrue:[ - newClass := Smalltalk at:nm. - newClass isNil ifTrue:[ - Transcript showCR:'oops - browser lost class ' , nm. - newClass := oldClass - ] ifFalse:[ - newClass := newClass theMetaclass - ] - ] ifFalse:[ - newClass := Smalltalk at:nm - ]. - newClass ~~ oldClass ifTrue:[ - anyChange := true. - ]. - newClass - ]. + nm := oldClass theNonMetaclass name. + oldClass isMeta ifTrue:[ + newClass := Smalltalk at:nm. + newClass isNil ifTrue:[ + Transcript showCR:'oops - browser lost class ' , nm. + newClass := oldClass + ] ifFalse:[ + newClass := newClass theMetaclass + ] + ] ifFalse:[ + newClass := Smalltalk at:nm + ]. + newClass ~~ oldClass ifTrue:[ + anyChange := true. + ]. + newClass + ]. classes := classes collect:refetch. leafClasses := leafClasses collect:refetch. anyChange ifTrue:[ - self updateOutputGenerator + self updateOutputGenerator ]. ! @@ -656,8 +656,8 @@ and:[newSelectedCategories notNil and:[(lastSelectedProtocols includes:(allEntry)) and:[newSelectedCategories includes:(allEntry)]]]) ifTrue:[ - "/ no change ... - ^ self + "/ no change ... + ^ self ]. super selectionChanged. @@ -960,11 +960,11 @@ class:cls protocol:cat includesMethodsInAnyPackage:packageFilter cls methodDictionary keysAndValuesDo:[:sel :mthd | - mthd category == cat ifTrue:[ - (packageFilter includes:mthd package) ifTrue:[ - ^ true - ] - ] + mthd category == cat ifTrue:[ + (packageFilter includes:mthd package) ifTrue:[ + ^ true + ] + ] ]. ^ false ! @@ -990,41 +990,41 @@ anyVarNameAccessable := cls allInstVarNames includesAny:variablesToHighLight. anyVarNameAccessable ifFalse:[ - anyVarNameAccessable := cls theNonMetaclass allClassVarNames includesAny:variablesToHighLight. + anyVarNameAccessable := cls theNonMetaclass allClassVarNames includesAny:variablesToHighLight. ]. anyVarNameAccessable ifFalse:[ - "/ no need to parse - ^ false + "/ no need to parse + ^ false ]. cls selectorsAndMethodsDo:[:sel :mthd | - |src parser usedVars| + |src parser usedVars| - mthd category = cat ifTrue:[ - src := mthd source. - src notNil ifTrue:[ - " - before doing a slow parse, quickly scan the - methods source for the variables name ... - " - (variablesToHighLight contains:[:varName | (src findString:varName) ~~ 0]) ifTrue:[ - parser := Parser - parseMethod:src - in:cls - ignoreErrors:true - ignoreWarnings:true. - (parser notNil and:[parser ~~ #Error]) ifTrue:[ - usedVars := parser perform:querySelector. - (usedVars includesAny:variablesToHighLight) - ifTrue:[ - ^ true - ] - ] - ] - ] ifFalse:[ - Transcript showCR:'Oops - cannot access methods source'. - ] - ] + mthd category = cat ifTrue:[ + src := mthd source. + src notNil ifTrue:[ + " + before doing a slow parse, quickly scan the + methods source for the variables name ... + " + (variablesToHighLight contains:[:varName | (src findString:varName) ~~ 0]) ifTrue:[ + parser := Parser + parseMethod:src + in:cls + ignoreErrors:true + ignoreWarnings:true. + (parser notNil and:[parser ~~ #Error]) ifTrue:[ + usedVars := parser perform:querySelector. + (usedVars includesAny:variablesToHighLight) + ifTrue:[ + ^ true + ] + ] + ] + ] ifFalse:[ + Transcript showCR:'Oops - cannot access methods source'. + ] + ] ]. ^ false ! @@ -1059,7 +1059,7 @@ emphasizedPlus emphasisForRef emphasisForMod numAll numObsolete numSuper numUncommented numDocumentation numLong numOverride numRedefine numExtension numMissingRequired numSubclassResponsibility showPseudoProtocols - addPseudoEntry countAll| + addPseudoEntry countAll pseudoEntryColor| countAll := true. @@ -1292,23 +1292,29 @@ self protocolLabelHolder value:nm ]. + pseudoEntryColor := self class pseudoEntryForegroundColor. + categoryList notEmpty ifTrue:[ noAllItem value ~~ true ifTrue:[ + |allName| + countAll ifTrue:[ - categoryList addFirst:((self class nameListEntryForALLWithCount bindWith:numAll) allItalic colorizeAllWith:Color grey). + allName := self class nameListEntryForALLWithCount bindWith:numAll. ] ifFalse:[ - categoryList addFirst:(nameListEntryForALL allItalic colorizeAllWith:Color grey). + allName := nameListEntryForALL. ]. + categoryList addFirst:(allName allItalic colorizeAllWith:pseudoEntryColor). rawProtocolList addFirst:nameListEntryForALL. ]. ]. + showPseudoProtocols value ifTrue:[ addPseudoEntry := [:s :n | n > 0 ifTrue:[ categoryList add:((s bindWith:n) allItalic - colorizeAllWith:Color grey). + colorizeAllWith:pseudoEntryColor). rawProtocolList add:s. ]. ]. @@ -1374,42 +1380,42 @@ sameContents := self updateListFor:newList. self selectedProtocolIndices addDependent:self. sameContents ifFalse:[ - prevSelection := lastSelectedProtocols ? (selectedProtocolsHolder value) ? #(). - "/ prevSelection := selectedProtocolsHolder value ? lastSelectedProtocols ? #(). + prevSelection := lastSelectedProtocols ? (selectedProtocolsHolder value) ? #(). + "/ prevSelection := selectedProtocolsHolder value ? lastSelectedProtocols ? #(). - rawList := self rawProtocolList value. - newSelection := prevSelection select:[:item | rawList includes:item string]. + rawList := self rawProtocolList value. + newSelection := prevSelection select:[:item | rawList includes:item string]. - newSelection size > 0 ifTrue:[ - "/ force change (for dependents) + newSelection size > 0 ifTrue:[ + "/ force change (for dependents) "/ selectedProtocolsHolder value:nil. "/ selectedProtocolsHolder value:newSelection. - selectedProtocolsHolder setValue:newSelection. - selectedProtocolsHolder changed:#value. - ] ifFalse:[ - prevSelection := selectedProtocolsHolder value. - selectedProtocolsHolder value:nil. - ]. - (prevSelection size > 0 or:[newSelection size > 0]) ifTrue:[ - self enqueueDelayedUpdateOutputGenerator. - "/ self updateOutputGenerator. - ]. + selectedProtocolsHolder setValue:newSelection. + selectedProtocolsHolder changed:#value. + ] ifFalse:[ + prevSelection := selectedProtocolsHolder value. + selectedProtocolsHolder value:nil. + ]. + (prevSelection size > 0 or:[newSelection size > 0]) ifTrue:[ + self enqueueDelayedUpdateOutputGenerator. + "/ self updateOutputGenerator. + ]. "/ prevSelection notNil ifTrue:[ "/ lastSelectedProtocols := prevSelection. "/ ]. ] ifTrue:[ - "/ same list - but classes might have changed - "/ that is the case, if the class selection has been changed, - "/ to another class which has the same categories. - (prevClasses size ~= classes size - or:[prevClasses asOrderedCollection ~= (classes ? #()) asOrderedCollection ]) ifTrue:[ - (newList size > 0 or:[oldList size > 0]) ifTrue:[ - self updateOutputGenerator - ] - ] ifFalse:[ + "/ same list - but classes might have changed + "/ that is the case, if the class selection has been changed, + "/ to another class which has the same categories. + (prevClasses size ~= classes size + or:[prevClasses asOrderedCollection ~= (classes ? #()) asOrderedCollection ]) ifTrue:[ + (newList size > 0 or:[oldList size > 0]) ifTrue:[ + self updateOutputGenerator + ] + ] ifFalse:[ "/ self protocolList value:newList. - ] + ] ]. listValid := true. @@ -1565,7 +1571,7 @@ "/ those are simulated - in ST/X, empty categories do not "/ really exist; however, during browsing, it makes sense. AdditionalEmptyCategoriesPerClassName notNil ifTrue:[ - AdditionalEmptyCategoriesPerClassName removeKey:aClass name ifAbsent:nil + AdditionalEmptyCategoriesPerClassName removeKey:aClass name ifAbsent:nil ]. @@ -1747,11 +1753,11 @@ !MethodCategoryList class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.50 2009-10-29 17:29:14 cg Exp $' + ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.51 2009-10-29 17:56:10 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.50 2009-10-29 17:29:14 cg Exp $' + ^ '$Header: /cvs/stx/stx/libtool/Tools_MethodCategoryList.st,v 1.51 2009-10-29 17:56:10 cg Exp $' ! ! MethodCategoryList initialize!