"====================================================================== | | Smalltalk GUI class hierarchy browser | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Brad Diller. Namespace support by Paolo Bonzini. | | This file is part of GNU Smalltalk. | | GNU Smalltalk is free software; you can redistribute it and/or modify it | under the terms of the GNU General Public License as published by the Free | Software Foundation; either version 2, or (at your option) any later version. | | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS | FOR A PARTICULAR PURPOSE. See the GNU General Public License for more | details. | | You should have received a copy of the GNU General Public License along with | GNU Smalltalk; see the file COPYING. If not, write to the Free Software | Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ====================================================================== " GuiData subclass: #ClassHierarchyBrowser instanceVariableNames: 'curClass curCategory curSelector textMode meta classList sortedMethodsByCategoryDict categoriesForClass topClasses shownClasses fileoutDir' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Browser' ! !ClassHierarchyBrowser methodsFor: 'initializing'! openOn: startingClass "Create and open a class hierarchy browser on startingClass" | topView upper container win list textView pane | meta := false. "Create top view" topView := (BrowserShell new: 'Class Hierarchy Browser') data: self. win := topView blox. win x: 20 y: 0 width: 604 height: 404. win createToplevelWindow: 'browser'. pane := Form new: 'panes' in: topView. topView addChildView: pane. container := pane blox. upper := Form new: 'ListForms' in: pane. pane addChildView: upper. container := upper blox. container xPixels: 2; yPixels: 2; width: 600; height: 200; heightOffset: -4. self initClassPane: upper. "Add method categories list pane in middle third of window" upper addChildView: ((list := PList new: 'Categories' in: upper) initialize; data: self; stateChange: #methodCategories; changedSelection: #removeCategorySelection; handleUserChange: #listMethodCategory:; listMsg: #methodCategories; hiliteItemInitMsg: #methodCategory; menuInit: (self blueButtonMenuForCategories: list); yourself). list blox x: 200; width: 200; height: 200; heightOffset: -50. self initRadioButtons: upper. "Add selectors list pane in top right third of window" upper addChildView: ((list := PList new: 'Selectors' in: upper) initialize; data: self; stateChange: #methods; handleUserChange: #method:; listMsg: #methods; hiliteItemInitMsg: #method; menuInit: (self blueButtonMenuForMethods: list); yourself). list blox x: 400; width: 200; height: 200; heightOffset: -4. pane addChildView: ((textView := PCode new: pane) data: self; stateChange: #text; handleUserChange: #compile:from:; menuInit: (self blueButtonMenuForText: textView); textMsg: #text; yourself). textView blox xPixels: 2; width: 600; height: 200. textView blox posVert: (upper blox). topClasses := startingClass isNil ifTrue: [ Array streamContents: [ :stream | Namespace current allClassesDo: [ :each | stream nextPut: each ] ]] ifFalse: [ Array with: startingClass ]. topClasses size >= 2 ifTrue: [ topClasses := topClasses asSortedCollection: [ :a :b | a name <= b name ] ]. self classList: (self hierarchyNames: topClasses) message: #classList. topView display. ! ! !ClassHierarchyBrowser methodsFor: 'accessing'! classList ^classList ! classList: curClassList message: aMessage "This method is used to implement selective updates of the class list pane. Currently the selected class, curClass, is unselected and the instance variables, curSelector and curCategory, which are related to the selected class, are reinitialized. The message type, aMessage, is sent to the data object. The update method for the affected class pane will update the portion which needs to be updated based on the message type parameter, aMessage. Other messages are posted through the change/update mechanism so that the rest of the window will be appropriately updated." classList := curClassList. curSelector := nil. curCategory := nil. textMode := #source. self changeState: aMessage; changeState: #methodCategories; changeState: #methods. self changeState: #text. Primitive updateViews. ! classSelection: assoc "assoc contains current class selection. Find the class associated with the selected string in shownClasses dictionary. Save the class in the instance variable, curClass. Update other related instance variables. Since the other panes in the browser descend from the class, the instance variables associated with each pane must be nilled out. Send update messages to the data object" curClass := ( assoc isNil or: [assoc value isNil]) ifTrue: [ nil ] ifFalse: [ shownClasses at: assoc value ]. curSelector := nil. curCategory := nil. textMode := #source. self changeState: #methodCategories; changeState: #methods. self changeState: #text. Primitive updateViews. ! classString "Return name of selected class indented by 'n' spaces, where 'n' is the number of class' superclasses" | spaces | curClass isNil ifTrue: [^nil]. spaces := String new: curClass allSuperclasses size. spaces atAllPut: Character space. ^spaces, curClass name ! meta "If class methods are being viewed, return true" ^meta ! meta: aBoolean "Change instance/class representation and record data state changes" meta = aBoolean ifTrue: [^self]. meta := aBoolean. curCategory := nil. curSelector := nil. self changeState: #methodCategories; changeState: #methods; changeState: #text. Primitive updateViews. ! method "Return the selected method which is stored in curSelector" ^curSelector ! method: assoc "Set curSelector to aMethod, update text mode, and record state change" curSelector := assoc value. textMode := #source. self changeState: #text. Primitive updateViews. ! methodCategories "This method is invoked by the change/update mechanism when a new class is selected. To improve efficiency, method dictionary is cached. Methods are sorted by category and saved in a dictionary, sortedMethodByCategoryDict. When a new category is selected, this dictionary is consulted. The class's method categories sorted by name are returned" | deClass category catSet| curClass isNil ifTrue: [^SortedCollection new]. deClass := self getClass. (categoriesForClass = deClass) ifTrue: [^sortedMethodsByCategoryDict keys asSortedCollection]. categoriesForClass := deClass. sortedMethodsByCategoryDict := Dictionary new. catSet := Set new. deClass selectors do: [ :aSelector | catSet add: (category := (deClass compiledMethodAt: aSelector) methodCategory). (sortedMethodsByCategoryDict at: category ifAbsent: [sortedMethodsByCategoryDict at: category put: SortedCollection new]) add: aSelector. ]. ^catSet asSortedCollection. ! methodCategory ^curCategory ! listMethodCategory: assoc curCategory := assoc value. self methodCategory: curCategory. ! methodCategory: listItem "Update curCategory. Reinitialize the instance variable, curSelector. Notify affected panes through the change/update mechanism" curCategory := listItem. textMode := #source. self changeState: #methods. "If a method is currently selected, perform this update only" curSelector notNil ifTrue: [ curSelector := nil. self changeState: #text]. Primitive updateViews. ! methods "Return the sorted methods for selected category" ( curCategory isNil) ifTrue: [ ^Array new: 0 ]. ^sortedMethodsByCategoryDict at: curCategory ifAbsent: [ Array new: 0]. ! text "Return a text string depending on the text mode (textMode) of the data object" | aStream count | textMode == #addClass "Return an add class template" ifTrue: [^self getAddClassTemplate]. (curClass isNil ) "If no class is selected, return empty string " ifTrue: [^String new: 0]. (textMode == #printHierarchy) "Return class hierarchy of selected class. The name of the class and its set of instance variables are displayed for each class in the hierarchy" ifTrue: [^self printHierarchy]. (textMode == #printBytecodes) "Return bytecodes for the method." ifTrue: [^self printBytecodes ]. (textMode == #comment) "Return comment associated with selected class" ifTrue: [self getClass comment isNil ifTrue: [^''] ifFalse: [^curClass comment]]. (textMode == #addMethod) "Return new method template" ifTrue: [^self getClass -> 'newMethod' ]. (curSelector isNil) ifTrue: [ aStream := WriteStream on: (String new: 0). curClass fileOutDeclarationOn: aStream. ^aStream contents]. "Display method source for selected class" ^self getClass -> (self getClass sourceCodeAt: curSelector). ! ! !ClassHierarchyBrowser methodsFor: 'category list blue button menu'! addCategory: listView "If a class is selected, prompt the user to enter a new message category. If a legitimate category is entered, update the method list pane (listView) and System classes" | newCategory | curClass isNil ifTrue: [^listView beep]. newCategory := (Prompter message: 'Enter a new message category' in: listView) response. newCategory ~= '' "If new category already exists, reject" ifTrue: [(sortedMethodsByCategoryDict includesKey: newCategory ) ifTrue: [^ModalDialog new alertMessage: 'Invalid name: the category, ' , newCategory, ', already exists.' in: listView] ] ifFalse: [^self]. sortedMethodsByCategoryDict at: newCategory put: SortedCollection new. self changeState: #methodCategories. self methodCategory: newCategory. ! fileOutCategory: listView "File out a description of the methods which belong to the selected method category. A file selection dialog is displayed which prompts the user for the name and directory location of the file" | fileName deClass | curCategory isNil ifTrue: [^listView beep]. deClass := self getClass. deClass name notNil ifTrue: [ fileName := deClass name ] ifFalse: [ fileName := (deClass instanceClass name) , '-class' ]. "If the name is too long, maybe truncate it?" fileName := self fileoutDir , fileName , '.' , curCategory , '.st' . fileName := Prompter saveFileName: 'File out category' default: fileName in: listView. fileName notEmpty ifTrue: [ deClass fileOutCategory: curCategory to: fileName. self setFileoutDirFromFile: fileName ] ! removeCategory: listView "Remove currently selected message category" | cancel | curCategory isNil ifTrue: [^listView beep]. ModalDialog new message: ('Are you sure you want to remove the category, ', curCategory, '?') in: listView; addButton: 'Yes' message: [cancel := false]; addButton: 'No' message: [cancel := true]; display: listView. cancel ifTrue: [^self]. "Update category list" (self methods notNil) "Update sorted cache of class's message dictionary" ifTrue: [ sortedMethodsByCategoryDict removeKey: curCategory ifAbsent: [^self]. self getClass removeCategory: curCategory]. "Nil out curCategory and notify affected panes through the change/update mechanism" curCategory := nil. self changeState: #methodCategories; changeState: #methods; changeState: #text. Primitive updateViews. ! renameCategory: listView "Change selected message category name" | newName| curCategory isNil ifTrue: [^listView beep]. "Prompt the user for new name" newName := (Prompter message: ('Rename message category: ' , curCategory) in: listView) response. newName ~= '' "If new category already exists, reject" ifTrue: [(sortedMethodsByCategoryDict includesKey: newName ) ifTrue: [^ModalDialog new alertMessage: 'Invalid name: the category, ' , newName, ', already exists.' in: listView] ] ifFalse: [^self]. "If new name is entered, update cache of sorted methods" sortedMethodsByCategoryDict at: newName put: (sortedMethodsByCategoryDict at: curCategory). sortedMethodsByCategoryDict removeKey: curCategory. "Update Smalltalk system" self getClass methodDictionary do: [ :method | (method methodCategory) = curCategory ifTrue: [method methodCategory: newName] ]. "Update instance variable and directly update the category pane (listView)" curCategory := newName. self changeState: #methodCategories. Primitive updateViews. ! blueButtonMenuForCategories: theView "Install popup menu for category pane" ^(PopupMenu new: theView label: '') selectors: #(('File out...' fileOutCategory: theView ) () ('Add...' addCategory: theView) ('Rename...' renameCategory: theView) ('Remove...' removeCategory: theView) ) receiver: self argument: theView ! ! !ClassHierarchyBrowser methodsFor: 'class list blue button menu'! addClass: classList "When 'add' is selected from class pane popup menu, this action is invoked. Update mode of text pane. Nil out currently selected method and method category. Record state change" (curClass notNil and: [classList canChangeState]) ifFalse: [^classList beep]. textMode := #addClass. curCategory := nil. curSelector := nil. self changeState: #removeCategorySelection; changeState: #methods; changeState: #text. Primitive updateViews. ! classRefs: listView "Activated from class pane popup menu. Open a message set browser on all methods that refer to currently selected class" | alert classes assoc | curClass isNil ifTrue: [^listView beep]. classes := SortedCollection new. assoc := Smalltalk associationAt: curClass name asSymbol. "For all selectors which refer to the selected class, add the class name concatenated with selector name in the sorted collection 'classes'" CompiledMethod allInstancesDo: [ :method | (method refersTo: assoc) ifTrue: [ classes add: method printString]]. classes isEmpty ifTrue: [ ^alert := ModalDialog new alertMessage: 'No references to ' , (curClass name) in: listView]. MethodSetBrowser new openOn: classes title: ('References to ', curClass name) selection: curClass name. ! comment: aPList "Change text mode to comment mode. Trigger an update to the text and selector panes" curClass isNil ifTrue: [^aPList beep]. "Ask the data object whether the class list view can change itself" aPList canChangeState ifFalse: [^self]. textMode := #comment. "Deselect currently selected selector" curSelector := nil. self changeState: #methods; changeState: #text. Primitive updateViews. ! compileAll: listView "Activated from class list popup. Recompile the selected class and its subclasses. The Metaclasses are recompiled as well" curClass isNil ifTrue: [^listView beep]. curClass compileAll. curClass class compileAll. curClass compileAllSubclasses. curClass class compileAllSubclasses. ! compileClass: listView "Recompile selected class and its Metaclass" curClass isNil ifTrue: [^listView beep]. curClass compileAll. curClass class compileAll ! fileoutDir | home | fileoutDir isNil ifTrue: [ "If the image directory is a subdirectory of the home directory, the default is the image directory. Else the default is the home directory" fileoutDir := Directory image, '/'. home := Directory home. home = '.' ifTrue: [ home := Directory working ]. home isEmpty ifFalse: [ fileoutDir size < home size ifTrue: [ ^fileoutDir := home, '/' ]. home = (fileoutDir copyFrom: 1 to: home size) ifTrue: [ ^fileoutDir := home, '/' ]. ] ]. ^fileoutDir ! setFileoutDirFromFile: fileName fileoutDir := fileName copyFrom: 1 to: ( fileName findLast: [ :c | c = $/ ]) ! fileOutClass: listView "File out a description of the currently selected class" | className fileName | curClass isNil ifTrue: [^listView beep]. curClass name notNil ifTrue: [ className := curClass name ] ifFalse: [ className := (curClass instanceClass name) , '-class' ]. fileName := self fileoutDir, className , '.st'. fileName := Prompter saveFileName: 'File out class' default: fileName in: listView. fileName ~= '' ifTrue: [curClass fileOut: fileName. self setFileoutDirFromFile: fileName ]. ! getAddClassTemplate "Return add class template" | aFileStream | aFileStream := WriteStream on: (String new: 0). curClass isNil ifTrue: [aFileStream nextPutAll: 'NameOfSuperClass '] ifFalse: [aFileStream nextPutAll: curClass printString;space]. aFileStream nextPutAll: 'subclass: '; nextPutAll: '#NameOfClass'; nl; tab. aFileStream nextPutAll: 'instanceVariableNames: '''''; nl; tab; nextPutAll: 'classVariableNames: '''''; nl; tab; nextPutAll: 'poolDictionaries: '''''; nl; tab; nextPutAll: 'category: nil'; nl. ^aFileStream contents. ! hierarchy: classList "Invoked from class pane popup. Change text mode and cause text and method pane to be updated via the change/update mechanism" curClass isNil ifTrue: [^classList beep]. "Ask the data object whether the class list view can change itself" classList canChangeState ifFalse: [^self]. textMode := #printHierarchy. curSelector := nil. self changeState: #methods; changeState: #text. Primitive updateViews. ! bytecodes: classList "Invoked from class pane popup. Change text mode and cause text and method pane to be updated via the change/update mechanism" curClass isNil ifTrue: [^classList beep]. "Ask the data object whether the class list view can change itself" classList canChangeState ifFalse: [^self]. textMode := #printBytecodes. self changeState: #text. Primitive updateViews. ! printBytecodes | stream | curSelector isNil ifTrue: [ ^'' ]. stream := WriteStream on: (String new: 500). (curClass compiledMethodAt: curSelector) printByteCodesOn: stream. ^stream contents ! printHierarchy "Return class or Metaclass hierarchy of selected class" | indent aStream classes aClass | indent := ''. aStream := WriteStream on: (String new: 80). aClass := meta ifTrue: [ curClass class] ifFalse: [ curClass]. classes := aClass allSuperclasses. classes addFirst: aClass. classes reverseDo: [:each | aStream nextPutAll: indent; nextPutAll: (each nameIn: Namespace current); space; print: each instVarNames; nl. indent := indent , ' ' ]. ^aStream contents. ! removeClass: listView "Remove selected class from Smalltalk system" | alert classes cancel | curClass isNil ifTrue: [^listView beep]. curClass subclasses isEmpty ifFalse: [^self error: 'Must delete subclasses first']. ModalDialog new message: ('Are you sure you want to remove the class, ', curClass name, '?') in: listView; addButton: 'Yes' message: [cancel := false]; addButton: 'No' message: [cancel := true]; display: listView. cancel ifTrue: [^self]. "If there are any instance of curClass, disallow curClass to be removed. Force a garbage collection to get rid of unreferenced instances" ((curClass instanceCount > 0) and: [Smalltalk compact. curClass instanceCount > 0]) ifTrue: [^self error: 'Cannot remove because class has instances.']. "Search Smalltalk system for all external references to class " Smalltalk allBehaviorsDo: [:subclass | (subclass ~~ curClass) & (subclass ~~ curClass class) ifTrue: [(subclass whichSelectorsReferTo: (Smalltalk associationAt: curClass name)) do: "Ignore references in transitory selector -- executeStatements" [ :sel | (sel ~= #executeStatements) ifTrue: [^self error: 'Must purge external references to class which is to be deleted']]]]. curClass allSuperclassesDo: [ :each | each removeSubclass: curClass]. "Update Smalltalk dictionary" Smalltalk removeKey: curClass name asSymbol. self updateClassList. self classSelection: nil. ! renameClass: listView "Rename currently selected class" | alert classes oldName newName prompter oldAssoc | curClass isNil ifTrue: [^listView beep]. oldName := curClass name. "Prompt user for new name" prompter := Prompter message: ('Rename class: ' , curClass name) in: listView. prompter response ~= '' ifFalse: [^self] ifTrue: [ newName := prompter response asSymbol. (newName at: 1) isUppercase ifFalse: [^self error: 'Class name must begin with an uppercase letter']. (Smalltalk includesKey: newName) ifTrue: [^self error: newName , ' already exists' ] ]. "Save old Association" oldAssoc := Smalltalk associationAt: oldName. "Rename the class now" curClass setName: newName asSymbol. "Fix up Smalltalk dictionary" Smalltalk at: (curClass name) put: (Smalltalk at: oldName). Smalltalk removeKey: oldName. "Notify programmer of all references to renamed class" classes := SortedCollection new. CompiledMethod allInstancesDo: [ :method | (method refersTo: oldAssoc) ifTrue: [ classes add: method printString]]. classes isEmpty ifFalse:[alert := ModalDialog new alertMessage: ('Rename all references to class ' , oldName , Character nl asSymbol , 'to the new name: ', newName ) in: listView. MethodSetBrowser new openOn: classes title: ('References to ', oldName) selection: oldName]. "Update class list" self updateClassList. ! searchClass: listView | newClass | newClass := (Prompter message: 'Enter the class to be searched' in: listView) response. newClass isEmpty ifTrue: [ ^self ]. curClass := Smalltalk classAt: newClass asSymbol ifAbsent: [ ^ModalDialog new alertMessage: 'Invalid name: the class, ' , newClass, ', does not exist.' in: listView ]. self searchForClassIn: listView ifAbsent: [ self updateClassList. self searchForClassIn: listView ifAbsent: [ ] ] ! searchForClassIn: listView ifAbsent: aBlock | indent label i listBlox numClasses | indent := ''. i := 1. listBlox := listView blox. numClasses := listBlox size. curClass withAllSuperclasses reverseDo: [ :each | label := indent, each printString. indent := indent, ' '. [ i > numClasses ifTrue: [ ^aBlock value ]. (listBlox labelAt: i) = label ] whileFalse: [ i := i + 1 ] ]. listBlox show: i ! updateClassList "Invoked from class list pane popup. Update class list pane through the change/update mechanism" self classList: (self hierarchyNames: topClasses) message: #classList. ! blueButtonMenuForClasses: theView "Install popup for class list popup" ^(PopupMenu new: theView label: '') selectors: #(('File out...' fileOutClass: theView) ('Update' updateClassList ) () ('Compile' compileClass: theView) ('Compile all' compileAll: theView ) () ('Bytecodes' bytecodes: theView ) ('Hierarchy' hierarchy: theView ) ('Comment' comment: theView ) ('Class refs' classRefs: theView ) () ('Add' addClass: theView ) ('Rename...' renameClass: theView ) ('Remove...' removeClass: theView ) ('Search...' searchClass: theView)) receiver: self argument: theView ! ! !ClassHierarchyBrowser methodsFor: 'private'! initRadioButtons: parent | radioGroup instBut classBut radioForm | radioForm := RadioForm new: 'RadioGroup' in: parent. radioGroup := radioForm blox. parent addChildView: radioForm. radioGroup x: 200; y: 200; yOffset: -50. radioForm addChildView: ( instBut := PRadioButton on: self parentView: radioGroup isPressed: #meta label: 'instance' handleUserChange: #meta: value: false ). instBut blox heightPixels: 25. radioForm addChildView: (classBut := PRadioButton on: self parentView: radioGroup isPressed: #meta label: 'class' handleUserChange: #meta: value: true ). classBut blox yPixels: 25; heightPixels: 25. ! initClassPane: parent | aClassList container classPane | classPane := Form new: 'classPane' in: parent. container := classPane blox. container height: 200. container width: 200. parent addChildView: classPane. classPane addChildView: ( (aClassList := PList new: 'Classes' in: classPane) initialize; data: self; "Register three types of messages" stateChange: #classList; changedSelection: #newClassSelection; handleUserChange: #classSelection:; listMsg: #classList; hiliteItemInitMsg: #classString; menuInit: (self blueButtonMenuForClasses: aClassList); yourself). aClassList blox height: 200; width: 200; heightOffset: -4. ! getClass "If 'meta' is true, return selected class's Metaclass; otherwise, selected class is returned" meta ifTrue: [ ^curClass class] ifFalse: [ ^curClass]. ! compileMethod: aString for: aView | compiledMethod selector dupIndex collection aClass | "Compile the method source, aString, for the selected class. Compilation class is set according to the radio button state. If 'meta' is true, set aClass to selected class, curClass, to its Metaclass. If method is successfully compiled, related instance variables are updated." aClass := meta ifTrue: [ curClass class] ifFalse: [ curClass]. "The exception block will be invoked if aString contains parsing errors. The description of the error will be displayed and selected at the end of the line in which the error is detected by the parser. Nil is returned" compiledMethod := (aClass compile: aString classified: curCategory ifError: [:fname :lineNo :errorString | aView displayError: errorString at: lineNo. ^nil ]). "Retrieve selector" selector := aClass selectorAt: compiledMethod. (selector ~= curSelector) ifFalse: [ ^compiledMethod ]. "Need to do additional housekeeping to keep RAM version of method dictionary, sortedMethodsByCategoryDict, in synch with the class's method dictionary. Remove duplicates stored in the RAM version of method dictionary" curSelector := selector. sortedMethodsByCategoryDict do: [ :methods | methods remove: curSelector ifAbsent: [ ] ]. "Now add selector to RAM copy" (sortedMethodsByCategoryDict at: curCategory ifAbsentPut: [SortedCollection new]) add: curSelector. self changeState: #methods. Primitive updateViews. ^compiledMethod ! hierarchyNames: startingClasses "Derived from examples/Publish.st" | collection topMetas | shownClasses := Dictionary new: 100. ^self makeDescendentsDictionary: (self makeFullTree: startingClasses) thenPutOn: (WriteStream on: (Array new: 75)). ! printHierarchyOf: dict hierarchy: desc startAt: root on: stream indent: indent "Recursive worker method for #printHierarchyOf:on: dict is the classes Dictionary as obtained by makeFullTree:, desc is the classes Dictionary as passed by makeDescendentsDictionary:thenCollectOn:" | subclasses string | subclasses := desc at: root. subclasses := subclasses asSortedCollection: [ :a :b | a name <= b name ]. subclasses do: [ :each || template | template := (dict at: each) ifTrue: [ '%1%2' ] ifFalse: [ '%1(%2)' ]. string := template bindWith: indent with: (each nameIn: Namespace current). shownClasses at: string put: each. stream nextPut: string. self printHierarchyOf: dict hierarchy: desc startAt: each on: stream indent: (indent, ' ') ]. ^stream contents ! makeFullTree: classes "From the classes collection, create a Dictionary in which we ensure that every key's superclass is also a key. For example, if classes contained Object and Array, the dictionary would also have Collection, SequenceableCollection and ArrayedCollection as keys. For every key, its value is true if classes includes it, else it is false." | dict newClasses checkClasses | dict := IdentityDictionary new: classes size. classes do: [ :each | dict at: each put: true ]. checkClasses := dict keys. [ newClasses := Set new. checkClasses do: [ :each | each superclass isNil ifFalse: [ (dict includesKey: each superclass) ifFalse: [ newClasses add: each superclass. ] ] ]. newClasses isEmpty ] whileFalse: [ newClasses do: [ :each | dict at: each put: false ]. checkClasses := newClasses. ]. ^dict ! makeDescendentsDictionary: dict thenPutOn: stream "From the dict Dictionary, created by #makeFullTree:, create another with the same keys. Each key is associated to a set of classes which are all the immediate subclasses which are also keys of dict. Then this dictionary is passed to the recursive method #printHierarchyOf:hierarchy:startAt:on:" | descendents | descendents := dict collect: [ :each | Set new ]. descendents at: #none put: Set new. dict keysDo: [ :each | each superclass isNil ifTrue: [ (descendents at: #none) add: each ] ifFalse: [ (descendents at: each superclass) add: each ] ]. ^self printHierarchyOf: dict hierarchy: descendents startAt: #none on: stream indent: '' ! ! !ClassHierarchyBrowser methodsFor: 'selector list blue button menu'! addMethod: listView "Change text mode of browser to add mode, #addMethod, and force an update by sending a message to the data object. This will subsequently force the text window to display a template for adding a new method" | prompter newMethodName| curCategory isNil ifTrue: [^listView beep] ifFalse: [ "Ask the data object whether the selector list view can change it" listView canChangeState ifFalse: [^self]. "Deselect currently selected method and force text pane, record state change and force update" listView unselect. textMode := #addMethod. self changeState: #text. Primitive updateViews]. ! fileOutSelector: listView "Creates a file containing description of selected method" | deClass fileName | curSelector isNil ifTrue: [^listView beep]. deClass := self getClass. deClass name notNil ifTrue: [ fileName := deClass name ] ifFalse: [ fileName := (deClass instanceClass name) , '-class' ]. "If the name is too long, maybe truncate it" fileName := self fileoutDir , fileName , '.' , curSelector , '.st' . fileName := Prompter saveFileName: 'File out selector' default: fileName in: listView fileName ~= '' ifTrue: [ deClass fileOutSelector: curSelector to: fileName. self setFileoutDirFromFile: fileName ]. ! removeMethod: listView "Removes selected method" | cancel | curSelector isNil ifTrue: [^listView beep]. ModalDialog new message: ('Are you sure you want to remove the method, ', curSelector ,'?') in: listView; addButton: 'Yes' message: [cancel := false]; addButton: 'No' message: [cancel := true]; display: listView. cancel ifTrue: [^self]. "Remove method from Smalltalk system" self getClass removeSelector: curSelector. (sortedMethodsByCategoryDict at: curCategory) remove: curSelector. "Update listView" curSelector := nil. "Record state change" self changeState: #methods; changeState: #text. Primitive updateViews. ! implementors: listView "Open a message set browser that sends the currently selected message" curSelector isNil ifTrue: [^listView beep]. MethodSetBrowser implementorsOf: curSelector parent: listView ! senders: listView "Open a message set browser that sends the currently selected message" curSelector isNil ifTrue: [^listView beep]. MethodSetBrowser sendersOf: curSelector parent: listView ! blueButtonMenuForMethods: theView "Create method list pane menu" ^(PopupMenu new: theView label: '') selectors: #(('File out...' fileOutSelector: theView ) () ('Senders' senders: theView) ('Implementors' implementors: theView) () ('Add' addMethod: theView) ('Remove...' removeMethod: theView) ) receiver: self argument: theView ! ! !ClassHierarchyBrowser methodsFor: 'text view blue button menu'! compile: aString from: aView "Compile aString derived from the text pane (aView). The way aString is compiled depends on the text mode" | aClass | curClass isNil ifTrue: [ ^aView beep ]. "If the text in the text pane is method source code, compile it" (curSelector notNil or: [ textMode == #addMethod ] ) ifTrue: [ ^self compileMethod: aString for: aView]. textMode == #comment ifTrue: [ curClass comment: aString. ^aString ]. "Otherwise, evaluate the text. If no method source is displayed, the aString is evaluated independently. If the string constitutes a legal class definition, the class is returned in aClass" aClass := Behavior evaluate: aString ifError: [ :file :line :msg | ^nil ]. aClass isClass ifFalse: [^nil]. "If ClassHierarchyBrowser is modified, force an immediate exit because this method context is still referencing it by the old memory model" (aClass == ClassHierarchyBrowser) | (aClass == curClass) ifTrue: [^self]. curClass := aClass. "Update class pane" (classList includes: self classString) "If the class already exists, inform the class pane indirectly through the change/update mechanism that the selection only needs to be updated" ifTrue: [self classList: classList message: #newClassSelection] "If the class does not exist, update instance variables and inform affected panes through the change/update mechanism" ifFalse: [self updateClassList]. textMode := #source. ! blueButtonMenuForText: theView "Create menu for text pane" ^(PopupMenu new: theView label: '') selectors: #(('Cut' gstCut) ('copy' gstCopy) ('Paste' gstPaste) () ('Clear' gstClear) () ('Line...' line) ('Find...' find) () ('Do it' eval) ('Print it' evalAndPrintResult) ('Inspect' evalAndInspectResult) () ('Accept' compileIt) ('Cancel' revert) () ('Close' close)) receiver: theView argument: nil. ! !