MUHRTH@tubvm.cs.tu-berlin.de (Thomas Muhr) (08/06/90)
Because of frequent requests I repost Max Ott's Category and Project Browser, which is a substantial upgrade to the ST V/286 environment, although there are a few features which are lacking or do not function properly. Anyway I already don't know how I could have been working without it. If trouble comes up, you can address the author whom I will send updates which have emerged during our experience with the browser. What follows is the original posting (I do not know if there have been upgrades in the meantime. - Have fun, - Thomas Received: by tub.UUCP; Mon, 26 Mar 90 23:15:59 +0100; AA25036 Received: by tmpmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 23:13:50 +0200; AA05263 Received: by netmbx.UUCP (5.61++/smail2.5); Mon, 26 Mar 90 22:52:33 +0200; AA00152 From: morus%netmbx.UUCP@tub.BITNET (Thomas Muhr) Message-Id: <9003262052.AA00152@netmbx.UUCP> Subject: catbrowser To: db0tui11.BITNET!muhrth@tub.UUCP Date: Mon, 26 Mar 90 22:52:30 MEST X-Mailer: ELM [version 2.2 PL7] " * ProjectClassHBrowser * Copyright (c) 1990 * By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp) * All rights reserved. * * This program is provided for UNRESTRICTED use provided that this * copyright message is preserved on all copies and derivative works. * This is provided without any warranty. No author or distributor * accepts any responsibility whatsoever to any person or any entity * with respect to any loss or damage caused or alleged to be caused * directly or indirectly by this program. This includes, but is not * limited to, any interruption of service, loss of business, loss of * information, loss of anticipated profits, core dumps, abuses of the * virtual memory system, or any consequential or incidental damages * resulting from the use of this program. * **************************** * * Project: categorized class browser * (Disk file: 'catInit.cls') fileIn; close. " Smalltalk at: #GlobalCategoryDictionary put: Dictionary new.! ClassReader subclass: #CategoryClassReader instanceVariableNames: 'category ' classVariableNames: '' poolDictionaries: '' ! !Behavior methods! addSelector: aSelector category: aCategory "add a selector to aCategory. Store this association in GlobalCategoryDictionary. As this is also used to file in new methods, better make sure that aSelector is not stored under a different category. !!!!!! max." | categories | categories := self allCategories. categories do: [ :cat | cat remove: aSelector ifAbsent: [ nil ] ]. ( categories at: aCategory ifAbsent: [ categories at: aCategory put: Set new ]) add: aSelector. ! allCategories "Return a dictionary with all the categories as keys. Each corresponding value contains a set of all the methods in this category. I used the basicHash as identifier for the class. I am not sure but storing self will put an instance into the global dictionary. It will then be impossible to add new instance variables to a method. This is at least the way I think this variable adding business works. Plain hash does not work as it uses the hash of the name which is not exclusive. If you change to another form of key, also change removeAllCategories. (should have its own method, though) !!!!!! max" | categories | categories := GlobalCategoryDictionary at: self basicHash ifAbsent: [ nil ]. categories isNil ifTrue: [ "put every method in default category" categories := Dictionary new. self selectors size = 0 ifFalse: [ "there is something to put" categories at: #etc put: self selectors ]. GlobalCategoryDictionary at: self basicHash put: categories. ]. ^categories! category: aSelector "returns the category for aSelector. If none is found return nil. !!!!!! max" | classDict answer | classDict := self allCategories. answer := ( classDict select: [ :aSet | aSet includes: aSelector ]) keys. answer size = 0 ifTrue: [ ^nil ]. answer size = 1 ifTrue: [ ^answer asArray at: 1 ]. self error: aSelector print, ' is stored under 2 different categories.'! categoryFor: aSelector "return the category of aSelector. !!!!!! max" self allCategories keysValuesDo: [ :aCategory :aSet | ( aSet detect: [ :sample | sample = aSelector ] ifNone: [ nil ]) isNil ifFalse: [ ^aCategory ] ]. self error: 'no category found for <', aSelector printString, '>'! changeCategoryFor: aSelector from: currentCategory to: newCategory "change the category of aSelector to newCategory. Don't check if everything is around. !!!!!! max" | categories | categories := self allCategories. ( categories at: currentCategory) remove: aSelector. ( categories at: newCategory) add: aSelector.! compile: codeString category: aCategory "Compile the Smalltalk method contained in codeString. The class to use for resolving variables is the receiver. If there are no errors, add the method to the receiver messageDictionary and also store the category. Further answer the Association with the message selector as the key and the compiled method as the value. If there is an error, answer nil. !!!! max" | answer | answer := Compiler compile: codeString in: self. answer notNil ifTrue: [ self addSelector: answer key category: aCategory; addSelector: answer key withMethod: answer value ]. ^answer! methodsInCategory: aCategory "Answer an instance of ClassReader initialized for the receiver. !!!!!! max" ^CategoryClassReader forClass: self category: aCategory asSymbol! methodsOrig "Answer an instance of ClassReader initialized for the receiver." ^ClassReader forClass: self! removeAllCategories "remove all categories for this class. Remove it from GlobalCategoryDictionary. This will be called when class is removed. !!!!!! max" GlobalCategoryDictionary removeKey: self basicHash ifAbsent: [ nil ]! removeCategory: aSymbol "remove a category from this class. Remove it from GlobalCategoryDictionary. !!!!!! max" self allCategories removeKey: aSymbol! removeSelector: aSelector category: aCategory "remove a selector from aCategory. Remove this association in GlobalCategoryDictionary. !!!!!! max." | categories | categories := self allCategories. ( categories at: aCategory) remove: aSelector.! renameCategoryFrom: oldCategory to: newCategory "rename category oldCategory to newCategory. Change it in GlobalCategoryDictionary. !!!!!! max" | classDict | classDict := self allCategories. classDict at: newCategory put: ( classDict at: oldCategory). classDict removeKey: oldCategory! selectorsForCategory: aCategory "Answer a Set of symbols of the names of the methods defined by the receiver which are in category aCategory. !!!!!! max" ^self allCategories at: aCategory! ! ClassReader subclass: #CategoryClassReader instanceVariableNames: 'category ' classVariableNames: '' poolDictionaries: '' ! !CategoryClassReader methods! fileInFrom: aStream "Read chunks from aStream until an empty chunk (a single '!!') is found. Compile each chunk as a method for the class described by the receiver. Log the source code of the method to the change log." | aString result stream | stream := Sources at: 2. stream setToEnd. self instanceHeaderOn: stream category: category. [(aString := aStream nextChunk zapCrs) isEmpty] whileFalse:[ result := class compile: aString category: category. result notNil ifTrue: [result value sourceString: aString]]. stream nextChunkPut: ''; flush! ! !CategoryClassReader class methods! forClass: aClass category: aCategory "Answer an instance of the receiver for aClass." ^self new setClass: aClass; setCategory: aCategory.! ! !CategoryClassReader methods! fileInFrom: aStream "Read chunks from aStream until an empty chunk (a single '!!') is found. Compile each chunk as a method for the class described by the receiver. Log the source code of the method to the change log." | aString result stream | stream := Sources at: 2. stream setToEnd. self instanceHeaderOn: stream category: category. [(aString := aStream nextChunk zapCrs) isEmpty] whileFalse:[ result := class compile: aString category: category. result notNil ifTrue: [result value sourceString: aString]]. stream nextChunkPut: ''; flush! fileOutOnWithCategories: aStream "File out all the methods for the class described by the receiver to aStream, in chunk format. Also add category names. !!!!!! don't forget to add Dictionary's keysValuesDo: " class allCategories keysValuesDo: [ :category :selectors | aStream cr. self instanceHeaderOn: aStream category: category. selectors asSortedCollection do: [ :selector | aStream cr; nextChunkPut: (class sourceCodeAt: selector) ]. aStream nextChunkPut: ''; cr ].! fileOutOnWithCategories: aStream selection: aSet "File out all the methods mentioned in aSet for the class described by the receiver to aStream, in chunk format. Also add category names. !!!!!! don't forget to add Dictionary's keysValuesDo: " ( self sortIntoCategories: aSet) keysValuesDo: [ :category :selectors | aStream cr. self instanceHeaderOn: aStream category: category. selectors asSortedCollection do: [ :selector | aStream cr; nextChunkPut: (class sourceCodeAt: selector) ]. aStream nextChunkPut: ''; cr ].! instanceHeaderOn: aStream category: aCategory "Private - Write a header to aStream which identifies the class described by the receiver. The header precedes the source code for the methods. Add category too." aStream cr; nextPut: $!!; nextPutAll: class name; space; nextPutAll: 'methodsInCategory: '; nextPutAll: aCategory asString printString; nextPut: $!!! sortIntoCategories: aSet "private - put all the methods in aSet into a dictionary where the key is the category and the value is a set containing all the methods belonging to the same category." | dictionary category | dictionary := Dictionary new. aSet do: [ :aSelector | category := class categoryFor: aSelector. dictionary at: category ifAbsent: [ dictionary at: category put: Set new ]. ( dictionary at: category) add: aSelector. ]. ^dictionary! setCategory: aCategory "Private - Set the category of the next read methods." category := aCategory. ^self! ! !Behavior methods ! methods "Answer an instance of ClassReader initialized for the receiver. This is an old script with no category, so we better put it in one. !!!!!! max" ^CategoryClassReader forClass: self category: #etc! checkCategories "Just to be sure. Check stored categories for double entries or selectors without categories. In case of a double entry, keep one and throw away the rest. Very simple. Too simple? Should not happen anyway. In case of no category, create xERRORx category and throw it in there. In this case update the category pane. Return set containing all the lost children." | set errorSet | set := Set new. self allCategories keysValuesDo: [ :cat :selectors | selectors do: [ :method | (set includes: method) ifTrue: [ "double entry; remove this one" selectors remove: method. Terminal bell ] ifFalse: [ "first time; store it" set add: method ] ] ]. errorSet := Set new. self selectors do: [ :method | (set includes: method) ifFalse: [ "this method has no category" errorSet add: method ] ]. ^errorSet! comment "return comment !!!!!! max" ^comment! comment: anObject "store anObject as comment !!!!!! max" ^comment := anObject! methodsOrig "Answer an instance of ClassReader initialized for the receiver." ^ClassReader forClass: self! ! !Dictionary methods ! keysValuesDo: aBlock "Answer the receiver. For each key in the receiver, evaluate aBlock with the key and the value as the arguments." self associationsDo: [ :anAssociation | aBlock value: anAssociation key value: anAssociation value]! ! !Pane methods ! popUp: aMenu at: aPoint "Display aMenu at aPoint. If the user choice is nil, do nothing. If the model can respond to the choice, let it perform the choice. Else, let the dispatcher perform it. !!max return immediatly if aMenu is nil. ( model doesn't want it.) deactivate pane before calling menu." | aSymbol | aMenu isNil ifTrue: [ ^self ]. self hasZoomedPane "deactivating zoomed pane causes dezooming" ifFalse: [ self deactivatePane ]. aSymbol := aMenu popUpAt: aPoint. self hasZoomedPane ifFalse: [ self activatePane ]. aSymbol isNil ifFalse: [ (model respondsTo: aSymbol) ifTrue: [model perform: aSymbol] ifFalse:[dispatcher perform: aSymbol]] ! ! " * ProjectClassHBrowser * Copyright (c) 1990 * By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp) * All rights reserved. * * This program is provided for UNRESTRICTED use provided that this * copyright message is preserved on all copies and derivative works. * This is provided without any warranty. No author or distributor * accepts any responsibility whatsoever to any person or any entity * with respect to any loss or damage caused or alleged to be caused * directly or indirectly by this program. This includes, but is not * limited to, any interruption of service, loss of business, loss of * information, loss of anticipated profits, core dumps, abuses of the * virtual memory system, or any consequential or incidental damages * resulting from the use of this program. * **************************** * Mar 20, 1990 22:08:13 * * Project: project_browser * (Disk file: 'catInit.cls') fileIn; close. (Disk file: 'prjct_br.cls') fileIn; close. To test it, execute: ProjectClassHBrowser new openOn: (Array with: Object) To install it as system menu default, execute: ProjectClassHBrowser install "! !Behavior methodsInCategory: 'comment'! commentFor: aVariable "return comment for aVariable !!!!!! max" comment isNil ifTrue: [ ^'not documented' ]. ^comment at: aVariable ifAbsent: [ 'not documented' ]! commentFor: aVariable put: aString "store comment aString for aVariable !!!!!! max" comment isNil ifTrue: [ comment := Dictionary new ]. ^comment at: aVariable put: aString! ! ClassHierarchyBrowser subclass: #CategorizedClassBrowser instanceVariableNames: 'selectedClassString selectedCategory currentCategory displayedMethod history ' classVariableNames: '' poolDictionaries: ''! CategorizedClassBrowser class comment: 'This browser adds the ability to group methods of a class into categories, like the big brother does. Compared with the ClassHierarchyBrowser, it adds one window in the center of the top half of the pane. This pane shows the categories defined for the currently selected class. Another small pane above the left half of the text pane shows the category of the currently selected method. The menu in this pane shows all the defined categories and can be used to change the category for the currently displayed method. '. CategorizedClassBrowser commentFor: 'selectedCategory' put: 'Contains the most recently selected category, or nil if no one is selcted. '. CategorizedClassBrowser commentFor: 'selectedClassString' put: 'Stores string of selected class as it appears in the class pane. This is necessary for the history to select a class in the class pane because the class names are indented. '. CategorizedClassBrowser commentFor: 'currentCategory' put: 'Contains the category of the currently displayed method in the text pane. '. CategorizedClassBrowser commentFor: 'displayedMethod' put: 'Contains the method currently displayed in the text pane. '. CategorizedClassBrowser commentFor: 'history' put: 'Contains the history of the last few selected methods. This way it is a bit easier to jump between methods in different classes. The length of the history list is set in <history length>. See category history for more details on the structure of each data item in this list. '. ! CategorizedClassBrowser subclass: #ProjectClassHBrowser instanceVariableNames: 'projectName changeDirectory changeLog ' classVariableNames: 'Projects ' poolDictionaries: ''! ProjectClassHBrowser class comment: 'This class browser keeps track of all the classes and methods created while working on a particular project. Selecting the <file out> option in the top pane menu files out all the changed and newly created master pieces. This file also includes a header for conviniently restoring the contents within an other image. I also use it as a kind of documentation. '. ProjectClassHBrowser commentFor: 'changeDirectory' put: 'All projects are stored in the class variable Projects. Projects is a dictionary with the project names as keys and a separate dictionary for each project as values. changeDirectory contains a pointer to this individual dictionary. '. ProjectClassHBrowser commentFor: 'Projects' put: 'Contains a list of all the currently known projects in this image. By starting up a new ProjectBrowser, the user will get a menu with all those names. '. ProjectClassHBrowser commentFor: 'changeLog' put: 'Not used yet. Had this idea of keeping a seperate change log file for each project. Not sure if this would be useful for anything. '. ProjectClassHBrowser commentFor: 'projectName' put: 'Contains the name of the project we are currently working on. The same name is also displayed in the window header. '. ! Object subclass: #ClassDocBrowser instanceVariableNames: 'class variable ' classVariableNames: '' poolDictionaries: ''! ClassDocBrowser class comment: 'A ClassDocBrowser supports reading and saving verbal explanation of the purpose of a class (stored in the pseudo variable CLASS) and all the instance, class, and pool variables. '. ClassDocBrowser commentFor: 'class' put: 'Contains the class we are displaying the documentation for. The docu text is stored in the instance variable <comment> in class Behavior. '. ClassDocBrowser commentFor: 'variable' put: 'Contains the currently selected variable. '. ! !CategorizedClassBrowser class methodsInCategory: 'bugs&info'! author "if you have any complaints, suggestions, or whatever send me a message under" ^'ott@piyopiyo.hatori.t.u-tokyo.ac.jp'! bugs "return string telling you about the known bugs" ^' CategorizedClassBrowser: ======================== 1) If you edit the name of a method and you change the category, you''ll change the category of the originally displayed method. This could be prevented by asking the text pane if it is modified before changing the category. However, we don''t keep the name of the text pane around. Would need a new instance variable and a check to <textPane dispatcher modified>'! ! !CategorizedClassBrowser methodsInCategory: 'classes'! addSubClass "Private - Add a subclass to the selected class. If a class is selected, prompt the user for a new class name and add it as a subclass to the selected class." | newName subclassType answer | selectedClass isNil ifTrue: [^self]. newName := Prompter prompt: selectedClass name , ' subclass?' default: ''. (newName isNil or: [newName isEmpty]) ifTrue: [^nil]. (newName at: 1) isUpperCase ifFalse: [ newName at: 1 put: (newName at: 1) asUpperCase]. newName := newName asSymbol. (Smalltalk includesKey: newName) ifTrue: [^self error: newName, ' already exists']. subclassType := (Menu labels: 'subclass\variableSubclass\variableByteSubclass' withCrs lines: Array new selectors: #(pointer indexed byte)) popUpAt: Cursor offset. (subclassType == #pointer and: [selectedClass isVariable]) ifTrue: [ (Prompter prompt: 'Indexed pointer subclass assumed. Confirm (y/n)' default: (String with: $y)) asLowerCase = (String with: $y) ifFalse: [^self]]. subclassType == #pointer ifTrue: [ ((selectedClass subclass: newName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '') isKindOf: Class) ifFalse: [^self]]. subclassType == #indexed ifTrue: [ ((selectedClass variableSubclass: newName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '') isKindOf: Class) ifFalse: [^self]]. subclassType == #byte ifTrue: [ ((selectedClass variableByteSubclass: newName classVariableNames: '' poolDictionaries: '') isKindOf: Class) ifFalse: [^self]]. subclassType isNil ifTrue: [^self]. selectedClass := Smalltalk at: newName asSymbol. CursorManager execute change. selectedMethod := nil. selectedCategory := nil. methodSelectedLast := false. self update: originalClasses. self changed: #hierarchy with: #restoreSelected: with: ((String new: (Smalltalk at: newName asSymbol) allSuperclasses size) atAllPut: $ ), newName. self changed: #categories; changed: #selectors; changed: #text! fileOut "Private - Write the source for the selected class in chunk file format to a file named with the class name reduced to 8 characters, extension 'cls'." | aFileStream | selectedClass isNil ifTrue: [^self]. CursorManager execute change. aFileStream := Disk newFile: (File fileName: selectedClass name extension: (String with: $c with: $l with: $s)). aFileStream lineDelimiter: 10 asCharacter. selectedClass fileOutOn: aFileStream. selectedClass fileOutDocOn: aFileStream. aFileStream nextChunkPut: String new. (CategoryClassReader forClass: selectedClass class) fileOutOnWithCategories: aFileStream. (CategoryClassReader forClass: selectedClass) fileOutOnWithCategories: aFileStream. aFileStream close. CursorManager normal change! getClass: aString "private - return the class object described by aString. If this class is not found, complain and return nil." | string aClass | string := aString. string last == $. ifTrue: [ string := string copyFrom: 1 to: string size - 3]. aClass := Smalltalk at: string trimBlanks asSymbol ifAbsent: [ Menu message: 'non-existent class'. self update. ^nil]. ^aClass! hideShow "Private - Change the hide/show status of the selected class." selectedClass isNil ifTrue: [^nil]. CursorManager execute change. (hiddenClasses includes: selectedClass) ifTrue: [ hiddenClasses remove: selectedClass] ifFalse: [ selectedClass subclasses isEmpty ifFalse: [ hiddenClasses add: selectedClass]]. methodSelectedLast := false. self initSelectedCategory. selectedMethod := nil. self update: originalClasses; changed: #hierarchy with: #restoreSelected; changed: #categories with: #restoreSelected: with: selectedCategory; changed: #selectors; changed: #text.! hierarchy: aString "Private - Display the selectors for the selected class in the selector list pane." | string aClass | string := aString. ( aClass := self getClass: aString) isNil ifTrue: [ ^self ]. selectedClassString := aString. selectedClass == aClass ifTrue: [^self hideShow]. methodSelectedLast := false. selectedMethod := nil. selectedClass := aClass. "if there is only one category; select it." self initSelectedCategory. selectedCategory isNil ifTrue: [ "start with the first item" self changed: #categories ] ifFalse: [ self changed: #categories with: #restoreSelected: with: selectedCategory ]. self changed: #selectors; changed: #text. self checkCategories.! removeSubClass "Private - Delete the selected class." | newName subclassType answer | selectedClass isNil ifTrue: [^nil]. newName := Prompter prompt: selectedClass name , ' to be deleted? (Y/N)' default: 'N'. newName isNil ifTrue: [^nil]. newName asUpperCase = 'Y' ifFalse: [^nil]. selectedClass removeFromSystem. selectedClass removeAllCategories. CursorManager execute change. selectedMethod := nil. selectedCategory := nil. methodSelectedLast := false. self update: originalClasses. self changed: #hierarchy with: #restore. selectedClass := nil. self changed: #categories; changed: #selectors; changed: #text! selectedClass "private - return the right receiver, either class or metaclass." ^instanceSelectedLast ifTrue: [ selectedClass ] ifFalse: [ selectedClass class ]! ! !CategorizedClassBrowser methodsInCategory: 'initialize'! initWindowSize "Private - Answer the initial window extent." ^Display width * 3 // 4 @ (Display height * 5 // 6)! openOn: aCollection "Create a class hierarchy browser window giving access to the classes in aCollection and their subclasses." | aTopPane listLineHeight ratio | hiddenClasses := Set new. history := OrderedCollection new: self historyLength. (aCollection includes: Object) ifTrue: [ aCollection do: [ :class | class subclasses do: [:each | each subclasses isEmpty ifFalse: [ hiddenClasses add: each]]]] ifFalse: [ aCollection do: [ :class | class subclasses isEmpty ifFalse: [ hiddenClasses add: class]]]. ratio := 2 / 5. self update: aCollection. listLineHeight := ListFont height + 4. instanceSelectedLast := true. methodSelectedLast := false. aTopPane := TopPane new model: self; label: self label; menu: #topMenu; minimumSize: 20 * SysFontWidth @ (10 * SysFontHeight); rightIcons: #(resize collapse zoom); foreColor: 0; backColor: 15; yourself. aTopPane addSubpane: (ListPane new model: self; name: #hierarchy; change: #hierarchy:; menu: #menu; framingBlock: [:box| box origin extent: (box width * 3 // 9 ) @ ((box height * ratio) truncated - listLineHeight)]). aTopPane addSubpane: ( ListPane new model: self; name: #categories; change: #category:; menu: #categoryMenu; framingBlock: [:box| box origin + (box width * 3 // 9 @ 0) extent: (box width * 2 // 9 ) @ ((box height * ratio) truncated - listLineHeight)]; yourself). aTopPane addSubpane: (ListPane new model: self; name: #selectors; change: #selector:; menu: #selectorMenu; framingBlock: [:box| box origin + ( box width * 5//9 @ 0) extent: (box width * 4 + 8 // 9) @ ((box height * ratio) truncated - listLineHeight)]). aTopPane addSubpane: (ListPane new model: self; name: #instances; change: #instance:; selection: 1; framingBlock: [:box| box origin+ (box width//2 @ ((box height * ratio) truncated - (listLineHeight))) extent: box width//4 @ (listLineHeight)]). aTopPane addSubpane: (ListPane new model: self; name: #classes; change: #class:; framingBlock: [:box| box origin+ (box width//2+(box width//4) @ ((box height * ratio) truncated - (listLineHeight))) extent: (box width - (box width//2) - (box width//4)) @ (listLineHeight)]). aTopPane addSubpane: (ListPane new model: self; name: #editedCategory; change: #suppressChange:; menu: #changeCategory; framingBlock: [:box| box origin+ (0 @ ((box height * ratio) truncated - (listLineHeight))) extent: box width//2 @ (listLineHeight)]). aTopPane addSubpane: ( TextPane new model: self; name: #text; menu: #textMenu; change: #accept:from:; framingRatio: (0 @ (ratio) corner: 1 @ 1); yourself). aTopPane dispatcher open scheduleWindow! ! !CategorizedClassBrowser methodsInCategory: 'test'! xTestx self inspect! ! !CategorizedClassBrowser methodsInCategory: 'text'! accept: aString from: aDispatcher "Private - Accept aString as an updated method or class specification and compile it. Notify aDispatcher if the compiler detects errors." | result aClass | methodSelectedLast ifFalse: [ ^self acceptClass: aString from: aDispatcher]. aClass := instanceSelectedLast ifTrue: [selectedClass] ifFalse: [selectedClass class]. result := self compile: aString notifying: aDispatcher in: aClass. result isNil ifTrue: [^false] ifFalse: [ Smalltalk logSource: aString forSelector: result key inClass: aClass. self successfulCompiledMethod: result key. result key == selectedMethod ifFalse: [ selectedMethod := result key. displayedMethod := result key. self selectedClass addSelector: result key category: currentCategory. selectedCategory := currentCategory. self addCurrentToHistory. self changed: #categories with: #restoreSelected: with: selectedCategory; changed: #selectors with: #restoreSelected: with: selectedMethod. ]. ^true]! compile: aString notifying: aDispatcher in: aClass "Private - Accept aString as an updated method and compile it. Notify aDispatcher if the compiler detects errors." | answer oldCursor class category confirm | oldCursor := Cursor. CursorManager execute change. class := self selectedClass. answer := Compiler compile: aString in: class notifying: aDispatcher ifFail: [ oldCursor change. ^nil]. oldCursor change. category := class category: answer key. ( category isNil or: [ category = currentCategory ]) ifFalse: [ confirm := Prompter prompt: answer key , ' also in <', category, '>. overwrite? (Y/N)' default: 'N'. confirm isNil ifTrue: [^nil]. confirm asUpperCase = 'Y' ifFalse: [^nil]. class changeCategoryFor: answer key from: category to: currentCategory ]. class addSelector: answer key withMethod: answer value. ^ answer! straightTextMenu "private - ask text pane to pop up normal text menu." self changed: #text with: #popUp: with: TextEditor menu! successfulCompiledMethod: aMethod "private - aMethod has been sucessfully compiled. Isn't that great. Have a beer."! text "Private - Answer the source text for the selected method or class definition for the selected class." selectedClass isNil ifTrue: [^String new]. currentCategory := methodSelectedLast ifTrue: [ selectedCategory ] ifFalse: [ nil]. self changed: #editedCategory. ^super text.! textMenu "private - if text pane contains method, return standard menu. If it shows class description, get doc menu." methodSelectedLast ifTrue: [ ^TextEditor menu ] ifFalse: [ ^self docMenu ]! ! !CategorizedClassBrowser methodsInCategory: 'history'! addCurrentToHistory "private - add current selection to the end of the history queue. If the queue is full, dump the first item." selectedMethod isNil ifTrue: [ ^nil ]. ( history size = self historyLength) ifTrue: [ history removeFirst ]. history addLast: (( Array new: 4) at: 1 put: selectedClassString; at: 2 put: selectedCategory; at: 3 put: selectedMethod; at: 4 put: instanceSelectedLast; yourself)! gotoClass: aClassString category: aCategory method: aMethod classInstance: aBoolean "private - display text for aMethod in class aClass and category aCategory. But before we change, check if class / instance was not changed." "self error: 'goto'. " aBoolean == instanceSelectedLast ifFalse: [ self changeClassInstance: aBoolean ]. selectedClass := self getClass: aClassString. selectedClassString := aClassString. selectedCategory := aCategory. selectedMethod := aMethod. displayedMethod := aMethod. methodSelectedLast := true. self addCurrentToHistory. self changed: #text; changed: #hierarchy with: #restoreSelected: with: aClassString; changed: #categories with: #restoreSelected: with: selectedCategory asSymbol; changed: #selectors with: #restoreSelected: with: selectedMethod.! historyLength "private - answer the length of the history queue." ^10! showHistory "private - pop up a menu with the last n selected methods." | labels selector index selected size | size := history size. labels := OrderedCollection new: size. history do: [ :anArray | ( selector := anArray at: 3) isNil ifFalse: [ labels addLast: selector asString ] ]. selectedMethod isNil "don't display current selected" ifFalse: [ labels removeLast ]. index := ( Menu labelArray: labels lines: Array new selectors: ( 1 to: labels size)) popUpAt: Cursor offset. index isNil ifTrue: [ ^nil ]. selected := history asArray at: index. self gotoClass: ( selected at: 1) category: ( selected at: 2) method: ( selected at: 3) classInstance: ( selected at: 4)! ! !CategorizedClassBrowser methodsInCategory: 'category'! addCategory "Private - Add a new category." | newCategory | selectedClass isNil ifTrue: [^self]. newCategory := Prompter prompt: selectedClass name , ' new category?' default: ''. newCategory isEmpty ifTrue: [ ^self ]. self selectedClass addCategory: newCategory asSymbol. selectedCategory := newCategory asSymbol. self changed: #categories with: #restoreSelected: with: selectedCategory asSymbol; changed: #selectors! categories "Private - Answer a sorted list of categories for the selected class." | selectors categories | selectedClass isNil ifTrue: [^Array new]. ^self selectedClass allCategories keys asSortedCollection! category: aSymbol "Private - Display the methods for this new category." selectedCategory := aSymbol asSymbol. selectedMethod := nil. "methodSelectedLast := false." self changed: #selectors! categoryMenu "Private - Answer the category pane menu." ^Menu labels: 'check\remove\rename\add\test' withCrs lines: #(1 4) selectors: #(checkCategories removeCategory renameCategory addCategory xTestx)! changeCategory "change the category of the currently displayed method. Display a list of all the defined categories." | categories newCategory | " currentCategory isNil no method displayed ifTrue: [ Terminal bell. ^nil ]. " categories := self categories asArray. newCategory := (Menu labelArray: categories lines: Array new selectors: categories) popUpAt: Cursor position. ( newCategory isNil or: [ newCategory = currentCategory]) ifFalse: [ displayedMethod isNil ifFalse: [ self selectedClass changeCategoryFor: displayedMethod from: currentCategory to: newCategory. currentCategory := newCategory. self changed: #selectors; changed: #editedCategory. ] ifTrue: [ Menu message: 'sorry, but you have to select method too'. ] ]. ^nil! checkCategories "Just to be sure. Check stored categories for double entries or selectors without categories. In case of a double entry, keep one and throw away the rest. Very simple. Too simple? Should not happen anyway. In case of no category, create xERRORx category and throw it in there. In this case update the category pane." | errorSet | selectedClass isNil ifTrue: [^self]. errorSet := self selectedClass checkCategories. errorSet isEmpty ifFalse: [ selectedCategory := #xERRORx. self selectedClass addCategory: selectedCategory. errorSet do: [ :selector | self selectedClass addSelector: selector category: selectedCategory ]. self changed: #categories with: #restoreSelected: with: selectedCategory; changed: #selectors ].! editedCategory "Private - Return the category of the currently displayed method." currentCategory isNil ifTrue: [^Array new]. ^( Array with: 'category: ', currentCategory) asSortedCollection! initSelectedCategory "private - if there is only one category select it straight away and show its selectors, otherwise set selectedCategory to nil." | dict | dict := self selectedClass allCategories. dict size = 1 ifFalse: [ ^selectedCategory := nil ]. "a strange way to get the only category" dict keys do: [ :k | selectedCategory := k ].! removeCategory "private - Delete selected category. But only if it does not contain any methods." self selectors size = 0 ifFalse: [ ^Menu message: 'Remove methods first!!']. self selectedClass removeCategory: selectedCategory. selectedCategory := nil. self changed: #categories! renameCategory "Private - Rename selected category." | newName | ( selectedClass isNil or: [ selectedCategory isNil ]) ifTrue: [^self]. newName := Prompter prompt: ' rename category: ', selectedCategory printString default: selectedCategory printString. ( newName isEmpty or: [ newName asSymbol = selectedCategory ]) ifTrue: [ ^self ]. self selectedClass renameCategoryFrom: selectedCategory to: newName asSymbol. selectedCategory := newName asSymbol. self changed: #categories with: #restoreSelected: with: selectedCategory.! suppressChange: aSymbol "private - the currentCategory pane got selected. Re-reverse the pane." self changed: #editedCategory! ! !CategorizedClassBrowser methodsInCategory: 'instanceClass'! changeClassInstance: aBoolean "private - if aBoolean is false change to class method display, otherwise change to instance display." aBoolean ifTrue: [ self changed: #classes; changed: #instances with: #restoreSelected: with: 1 ] ifFalse: [ self changed: #instances; changed: #classes with: #restoreSelected: with: 1 ]. instanceSelectedLast := aBoolean! class: aSymbol "Private - Change the state of the browser so that class messages are selected." instanceSelectedLast := methodSelectedLast := false. self initSelectedCategory. self changed: #categories with: #restoreSelected: with: selectedCategory; changed: #instances; changed: #selectors; changed: #text. self checkCategories.! instance: aSymbol "Private - Change the state of the browser so that instance messages are selected." instanceSelectedLast := true. methodSelectedLast := false. self initSelectedCategory. self changed: #categories with: #restoreSelected: with: selectedCategory; changed: #classes; changed: #selectors; changed: #text. self checkCategories.! ! !CategorizedClassBrowser methodsInCategory: 'classDoc'! docMenu "private - return menu to either edit the class description or display class documentation." ^Menu labels: 'documentation\edit' withCrs lines: Array new selectors: #(openDoc straightTextMenu)! openDoc "Open a pane for viewing and editing the class and variable documentation." ClassDocBrowser new openFor: selectedClass! ! !CategorizedClassBrowser methodsInCategory: 'selectors'! newMethod "Private - Display the text for a new method template in the text pane. Ask for category if none is selected" selectedClass isNil ifTrue: [self error: 'no class selected']. selectedCategory isNil ifTrue: [ self categories size = 0 ifTrue: [ self addCategory ] ]. selectedCategory isNil ifTrue: [ ^Menu message: 'select category first' ]. ^super newMethod! removeSelector "Private - Remove the selected method." | aString | methodSelectedLast ifFalse: [^nil]. selectedMethod isNil ifTrue: [^nil]. self selectedClass removeSelector: selectedMethod category: selectedCategory. ^super removeSelector! selector: aSymbol "Private - Display the selected method in the text pane." super selector: aSymbol. displayedMethod := aSymbol. self addCurrentToHistory.! selectorMenu "Private - Answer the selector pane menu." ^Menu labels: 'remove\new method\senders\implementors\history' withCrs lines: ( Array with: 4 ) selectors: #(removeSelector newMethod senders implementors showHistory)! selectors "Private - Answer a sorted list of method selectors for the selected class and dictionary type (class or instance)." ( selectedClass isNil or: [ selectedCategory isNil]) ifTrue: [^Array new]. ^(self selectedClass selectorsForCategory: selectedCategory) asSortedCollection! ! !CategorizedClassBrowser methodsInCategory: 'window'! collapsedLabel "Private - Answer the collapsed label." ^' CCHB '! label "Private - Answer the window label." ^'CClass Hierarchy Browser'! topMenu "private - return menu for the top pane. For this application return standard one." ^TopDispatcher menu! ! !Class methodsInCategory: 'etc'! fileOutDocOn: aStream "Append the class documentation for the receiver to aStream. !!!!!! max" | aString | aStream nextPut: $!!; "this should force the compiler to introduce the class, before we add the documentation." cr; cr; nextPutAll: self printString; space; nextPutAll: 'class comment: '; cr; nextPutAll: self class comment storeString, '.'; cr; cr. self comment keysValuesDo: [ :var :text | aStream nextPutAll: self printString; space; nextPutAll: 'commentFor: ', var storeString, ' put:'; cr; nextPutAll: text storeString; nextPutAll: '.'; cr; cr ]! ! !Behavior methodsInCategory: 'comment'! commentFor: aVariable "return comment for aVariable !!!!!! max" comment isNil ifTrue: [ ^'not documented' ]. ^comment at: aVariable ifAbsent: [ 'not documented' ]! commentFor: aVariable put: aString "store comment aString for aVariable !!!!!! max" comment isNil ifTrue: [ comment := Dictionary new ]. ^comment at: aVariable put: aString! ! !Behavior methodsInCategory: 'etc'! addCategory: aCategory "add a new category to the this class. !!!!!! max." | categories | categories := self allCategories. categories at: aCategory ifAbsent: [ categories at: aCategory put: Set new ]! categoryFor: aSelector "return the category of aSelector. !!!!!! max" self allCategories keysValuesDo: [ :aCategory :aSet | ( aSet detect: [ :sample | sample = aSelector ] ifNone: [ nil ]) isNil ifFalse: [ ^aCategory ] ]. "can't find a category. Check if selector is still around." self selectors detect: [ :anotherSelector | aSelector == anotherSelector ] ifNone: [ ^nil ]. "has been removed" Menu message: 'check categories in class <', name, '>'. ^#etc! ! !ProjectClassHBrowser class methodsInCategory: 'initialize'! initialize "initialize the class variables. Projects holds a dictionary with a key for each project." Projects := Dictionary new.! install "install the project browser in screen menu." ( ReadStream on: '!! ScreenDispatcher methods !! openClassBrowser "Private - Open a class hierarchy browser." ProjectClassHBrowser new openOn: (Array with: Object) !! !!') fileIn! ! !ProjectClassHBrowser class methodsInCategory: 'inquire'! projects "return a dictionary containing all projects." ^Projects! ! !ProjectClassHBrowser class methodsInCategory: 'bugs&info'! bugs "return string telling you about the known bugs" ^' ProjectClassHBrowser: ===================== 1) There is no way yet to add methods to a project when installing them from a file. Need some class methods like ProjectClassHBrowser project:addMethod: Maybe this should go in a seperate class anyway. 2) At the moment you can''t remove a method from a project, except by editing (ProjectClassHBrowser projects at:#project) inspect 3) For no particular reason the instance variable holding all the changes is called changeDirectory. Why ..Directory? Because it is a Dictionary. Reason enough? ', super bugs! ! !ProjectClassHBrowser methodsInCategory: 'selectors'! removeSelector "Private - Remove the selected method. Also remove it from the project directory." | tmp | methodSelectedLast ifFalse: [^nil]. selectedMethod isNil ifTrue: [^nil]. tmp := self classChangeDirectory. ( instanceSelectedLast ifTrue: [ tmp at: 1 ] ifFalse: [ tmp at: 2 ] ) remove: selectedMethod ifAbsent:[]. ^super removeSelector! selectorMenu "Private - Answer the selector pane menu." ^Menu labels: 'remove\new method\senders\implementors\add to project\history' withCrs lines: ( Array with: 4 ) selectors: #(removeSelector newMethod senders implementors addCurrentToProject showHistory)! ! !ProjectClassHBrowser methodsInCategory: 'initialize'! openOn: aCollection "Create a class hierarchy browser window giving access to the classes in aCollection and their subclasses. There is a project name associated with this window. Therefore we also keep a diary of all the methods changed while working on this project. Later we can ask to file out all the changed methods." | newName | Projects isNil ifTrue: [ ProjectClassHBrowser initialize ]. newName := self askForProjectName. newName isNil ifTrue: [ ^nil ]. changeDirectory := ( Projects at: newName ifAbsent: [ Projects at: newName put: Dictionary new ]). projectName := newName. ^super openOn: aCollection! ! !ProjectClassHBrowser methodsInCategory: 'project'! addCurrentToProject "private - add current selected method to project log." self addMethodToProject: selectedMethod! addMethodToProject: aMethod "private - add aMethod to the project log." | tmp | tmp := self classChangeDirectory. instanceSelectedLast ifTrue: [( tmp at: 1) add: aMethod ] ifFalse: [( tmp at: 2) add: aMethod ]! askForProjectName "private - ask user for new project name. Set variable projectName accordingly. First display a menu with all known projects. For new projects click the last menu line which will open a prompter to input the proper name. Return the new selected project name or nil if none was selected." | names index newName | names := Projects keys asOrderedCollection. names size = 0 ifTrue: [ index := 0 ] ifFalse: [ names addLast: '>> New Project?'. names := names asArray. index := ( Menu labelArray: names lines: Array new selectors: ( 1 to: names size)) popUpAt: Cursor offset. index isNil ifTrue: [ ^nil ] ]. index = names size ifTrue: [ "get new name" newName := Prompter prompt: ' Project name?' default: ''. newName isEmpty ifTrue: [ ^nil ]. ] ifFalse: [ newName := names at: index ]. ^newName! changeProjectName "private - ask user for a different name for the current project. update label. !!!!!! Don't know how to update collapsed label" | newName | ( newName := self typeNewProjectName) isNil ifTrue: [ ^nil ]. ( Projects at: newName ifAbsent: [ nil ]) isNil ifFalse: [ ^Menu message: '<', newName, '> is used for a different project' ]. Projects at: newName put: ( Projects at: projectName). Projects removeKey: projectName. projectName := newName. self changed: #label! classChangeDirectory "private - return an array for the selected class for adding new methods to change log. This array is stored in class variable Projects. The changeDirectory is the value of the dictionary entry for this project in the class variable Class. It is a dictionary with a key for each class changes have been made. For each class a array of 2 sets is kept, for instance methods and class methods respectively. We also set a flag if the class specifications were changed." changeDirectory at: selectedClass ifAbsent: [ changeDirectory at: selectedClass put: ( Array with: Set new with: Set new with: false) ]. ^changeDirectory at: selectedClass! fileOutProject "private - file out all the methods and class definitions changed or created while developing of this project." | aFileStream | changeDirectory isNil ifTrue: [^self]. CursorManager execute change. aFileStream := Disk newFile: (File fileName: projectName extension: (String with: $c with: $l with: $s)). aFileStream lineDelimiter: 10 asCharacter. self fileOutProjectHeaderOn: aFileStream. "first file out all the headers of all newly created classes to avoid references to a class before the new image knows about them." changeDirectory keysValuesDo: [ :aClass :changeArray | ( changeArray at: 3) "class was newly created" ifTrue: [ aClass fileOutOn: aFileStream. aClass fileOutDocOn: aFileStream. aFileStream nextChunkPut: String new. ] ]. changeDirectory keysValuesDo: [ :aClass :changeArray | ( changeArray at: 2) size == 0 "file out class definitions" ifFalse: [ ( CategoryClassReader forClass: aClass class) fileOutOnWithCategories: aFileStream selection: ( changeArray at: 2). ]. ( changeArray at: 1) size == 0 "file out methods" ifFalse: [ ( CategoryClassReader forClass: aClass ) fileOutOnWithCategories: aFileStream selection: ( changeArray at: 1). ]. ]. aFileStream close. CursorManager normal change! fileOutProjectHeaderOn: aFileStream "private - write some information on the current project at the beginning of the file." aFileStream nextPutAll: '"****************************'; cr; nextPutAll: ' * ', ( Date dateAndTimeNow at: 1) printString, ' ', ( Date dateAndTimeNow at: 2) printString; cr; nextPutAll: ' *'; cr; nextPutAll: ' * Project: ', projectName; cr; nextPutAll: ' *'; cr; cr; nextPutAll: ' (Disk file: ''', (File fileName: projectName extension: 'cls'), ''') fileIn; close.'; cr; nextPutAll: '"'; nextPut: $!!; cr.! topMenu | selection | ^Menu labels: 'change name\file out' withCrs lines: #() selectors: #(changeProjectName fileOutProject)! typeNewProjectName "private - ask user with a prompter for a new project name and return this name." | newName | newName := Prompter prompt: ' Project name?' default: ''. newName isEmpty ifTrue: [ ^nil ]. ^newName! ! !ProjectClassHBrowser methodsInCategory: 'text'! successfulCompiledMethod: aMethod "private - aMethod has been sucessfully compiled. Isn't that great. Have a beer. Also add it to the project log." self addMethodToProject: aMethod! ! !ProjectClassHBrowser methodsInCategory: 'classes'! acceptClass: aString from: aDispatcher "Private - Accept aString as an updated class specification and compile it. Notify aDispatcher if the compiler detects errors." | result | result := Compiler evaluate: aString in: nil class to: nil notifying: aDispatcher ifFail: [^false]. Smalltalk logEvaluate: aString. self classSpecificationsHaveChanged. ^(result isKindOf: Class)! classSpecificationsHaveChanged "private - mark in project log that the specifications for the currently selected class have changed." self classChangeDirectory at: 3 put: true! ! !ProjectClassHBrowser methodsInCategory: 'window'! collapsedLabel "Private - Answer the collapsed label." ^'<', projectName, '>'! label "Private - Answer the window label." ^'Project: <', projectName, '>'! ! !CategoryClassReader methodsInCategory: 'inOut'! instanceHeaderOn: aStream category: aCategory "Private - Write a header to aStream which identifies the class described by the receiver. The header precedes the source code for the methods. Add category too." aStream cr; nextPut: $!!; nextPutAll: class name; space; nextPutAll: 'methodsInCategory: '; nextPutAll: aCategory asString printString; nextPut: $!!! sortIntoCategories: aSet "private - put all the methods in aSet into a dictionary where the key is the category and the value is a set containing all the methods belonging to the same category." | dictionary category | dictionary := Dictionary new. aSet do: [ :aSelector | ( category := class categoryFor: aSelector) isNil ifFalse: [ "ok found a category for it" dictionary at: category ifAbsent: [ dictionary at: category put: Set new ]. ( dictionary at: category) add: aSelector. ] ]. ^dictionary! ! !ClassDocBrowser methodsInCategory: 'initialize'! docTextInit "private - show the class docu immediatly" | comment | variable := 'CLASS'. self changed: #variables with: #selection: with: 1. (comment := class class comment) isNil ifTrue: [ ^'not documented' ] ifFalse: [ ^comment ]! initWindowSize "Answer the initial window extent." ^Display width * 4 // 5 @ (Display height // 2)! openFor: aClass "Open a pane for viewing and editing the class and variable documentation." | aTopPane | class := aClass. aTopPane := TopPane new model: self; label: 'doc: ', class name; minimumSize: SysFontWidth * 20 @ (SysFontHeight * 8); yourself. aTopPane addSubpane: (ListPane new model: self; name: #variables; change: #variable:; " menu: #selectorMenu; " framingRatio: (0@0 extent: 1/5@1)). aTopPane addSubpane: (TextPane new model: self; name: #docText; change: #docChange:from:; framingRatio: (1/5@0 extent: 4/5@1)). aTopPane dispatcher open scheduleWindow! variables "private - return an array with all the instance and class variables." | list | list := OrderedCollection new. list addLast: 'CLASS'. class instanceVariableString asArrayOfSubstrings do: [ :l | list addLast: l ]. class classVariableString asArrayOfSubstrings do: [ :l | list addLast: l ]. ^list asArray! ! !ClassDocBrowser methodsInCategory: 'work'! docChange: aString from: aDispatcher "private - accept a new docu string. Store it in Behavior. CLASS docu in class class comment, variables in class comment as dictionary." | dict | variable = 'CLASS' ifTrue: [ "get class docu" class class comment: aString ] ifFalse: [ "write variable docu" class commentFor: variable put: aString ]. ^true! docText "return comment for selected variable." | comment dict | variable isNil ifTrue: [ ^self docTextInit ]. variable = 'CLASS' ifTrue: [ "get class docu" (comment := class class comment) isNil ifTrue: [ ^'not documented' ] ifFalse: [ ^comment ] ] ifFalse: [ "get variable docu" ^class commentFor: variable ]. ^'strange ERROR'! variable: aString "private - a new variable got selected; display its documentation." variable := aString. self changed: #docText.! !