[comp.lang.smalltalk] Smalltalk/V for PM V1.0 bug fixes & enhancements Part 8

cowan@marob.masa.com (John Cowan) (07/27/90)

"

Purpose of PROTOCOL.ST:

Implements a Protocol Browser option in ClassHierarchyBrowsers.
When selected, this option (under the Classes menu) browses
all methods to which the currently selected class responds,
including those defined (but not overridden) in all ancestor
classes.  Whether class or instance methods are browsed depends
on the setting of the appropriate buttons.

Also provides SystemDictionary>>allVariablesHolding:, which can be
used to find stray instances of classes to be changed or removed
which are being held in global variables.

"

! Behavior methods !  
fullProtocol
        "Return an OrderedCollection of all the methods implemented
        by this class and non-overridden methods in
        its superclasses."
    | result messages |
    result := OrderedCollection new.
    messages := Set new.
    dictionaryArray do:
        [:dict |
        dict keysDo: [:key |
            (messages includes: key)
                ifFalse: [result add: (dict at: key).
            messages add: key]]].
    ^result! !


! SystemDictionary methods ! 
allVariablesHolding: aClass
        "Answers an OrderedCollection of the names of
        global variables which hold instances of aClass."
    | answer |
    answer := OrderedCollection new.
    self keysDo: [:variable |
        ((self at: variable) isMemberOf: aClass) ifTrue:
            [answer add: variable]].
    ^answer! !


! SystemDictionary methods !  
protocolFor: aClass
        "Open a MethodBrowser on all methods
         named aSymbol in aClass and its subclasses."
    | methods |
    CursorManager execute change.
    methods := aClass fullProtocol.
    CursorManager normal change.
    MethodBrowser new
            label: 'Protocol for ', aClass printString;
            openOn: methods! !



! ClassHierarchyBrowser methods !   
menu: hierarchyPane
        "Private - Set the hierarchy pane menu."
    hierarchyPane setMenu: ((Menu
        labels: '~Add Subclass...\File ~Out...\~Update\~Hide/Show\~Browse\~Protocol\~Find Class...\~Remove Class' withCrs
        lines: #(1 7)
        selectors: #(addSubClass fileOut update hideShow browse protocol findClass removeSubClass))
            title: '~Classes';
            owner: self;
            yourself)! !
-- 
cowan@marob.masa.com			(aka ...!hombre!marob!cowan)
			e'osai ko sarji la lojban