c30943@tansei.cc.u-tokyo.ac.jp (max ott) (03/21/90)
#--------------------------------CUT HERE------------------------------------- #! /bin/sh # # This is a shell archive. Save this into a file, edit it # and delete all lines above this comment. Then give this # file to sh by executing the command "sh file". The files # will be extracted into the current directory owned by # you with default permissions. # # The files contained herein are: # # -rw-rw-rw- 1 ott 48521 Mar 21 15:52 prjct_br.cls # echo 'x - prjct_br.cls' if test -f prjct_br.cls; then echo 'shar: not overwriting prjct_br.cls'; else sed 's/^X//' << '________This_Is_The_END________' > prjct_br.cls X" X* ProjectClassHBrowser X* Copyright (c) 1990 X* By Max Ott (ott%piyopiyo.hatori.t.u-tokyo.ac.jp) X* All rights reserved. X* X* This program is provided for UNRESTRICTED use provided that this X* copyright message is preserved on all copies and derivative works. X* This is provided without any warranty. No author or distributor X* accepts any responsibility whatsoever to any person or any entity X* with respect to any loss or damage caused or alleged to be caused X* directly or indirectly by this program. This includes, but is not X* limited to, any interruption of service, loss of business, loss of X* information, loss of anticipated profits, core dumps, abuses of the X* virtual memory system, or any consequential or incidental damages X* resulting from the use of this program. X* X**************************** X* Mar 20, 1990 22:08:13 X* X* Project: project_browser X* X X (Disk file: 'catInit.cls') fileIn; close. X (Disk file: 'prjct_br.cls') fileIn; close. X X To test it, execute: X X ProjectClassHBrowser new openOn: (Array with: Object) X X To install it as system menu default, execute: X X ProjectClassHBrowser install X"! X X!Behavior methodsInCategory: 'comment'! X XcommentFor: aVariable X "return comment for aVariable X!!!!!! max" X comment isNil X ifTrue: [ X ^'not documented' X ]. X ^comment at: aVariable ifAbsent: [ 'not documented' ]! X XcommentFor: aVariable put: aString X "store comment aString for aVariable X!!!!!! max" X comment isNil X ifTrue: [ X comment := Dictionary new X ]. X ^comment at: aVariable put: aString! ! XClassHierarchyBrowser subclass: #CategorizedClassBrowser X instanceVariableNames: X 'selectedClassString selectedCategory currentCategory displayedMethod history ' X classVariableNames: '' X poolDictionaries: ''! X XCategorizedClassBrowser class comment: X'This browser adds the ability to group methods Xof a class into categories, like the big brother Xdoes. Compared with the ClassHierarchyBrowser, Xit adds one window in the center of the top Xhalf of the pane. This pane shows the categories Xdefined for the currently selected class. Another Xsmall pane above the left half of the text pane Xshows the category of the currently selected method. XThe menu in this pane shows all the defined Xcategories and can be used to change the Xcategory for the currently displayed method. X'. X XCategorizedClassBrowser commentFor: 'selectedCategory' put: X'Contains the most recently selected category, Xor nil if no one is selcted. X'. X XCategorizedClassBrowser commentFor: 'selectedClassString' put: X'Stores string of selected class as it appears Xin the class pane. This is necessary for the Xhistory to select a class in the class pane Xbecause the class names are indented. X'. X XCategorizedClassBrowser commentFor: 'currentCategory' put: X'Contains the category of the currently displayed Xmethod in the text pane. X'. X XCategorizedClassBrowser commentFor: 'displayedMethod' put: X'Contains the method currently displayed in Xthe text pane. X X'. X XCategorizedClassBrowser commentFor: 'history' put: X'Contains the history of the last few selected Xmethods. This way it is a bit easier to jump Xbetween methods in different classes. X XThe length of the history list is set in X<history length>. See category history for more Xdetails on the structure of each data item Xin this list. X'. X X ! XCategorizedClassBrowser subclass: #ProjectClassHBrowser X instanceVariableNames: X 'projectName changeDirectory changeLog ' X classVariableNames: X 'Projects ' X poolDictionaries: ''! X XProjectClassHBrowser class comment: X'This class browser keeps track of all the classes Xand methods created while working on a particular Xproject. Selecting the <file out> option in the Xtop pane menu files out all the changed and newly Xcreated master pieces. This file also includes Xa header for conviniently restoring the contents Xwithin an other image. I also use it as a kind Xof documentation. X'. X XProjectClassHBrowser commentFor: 'changeDirectory' put: X'All projects are stored in the class variable XProjects. Projects is a dictionary with the Xproject names as keys and a separate dictionary Xfor each project as values. changeDirectory Xcontains a pointer to this individual dictionary. X'. X XProjectClassHBrowser commentFor: 'Projects' put: X'Contains a list of all the currently known Xprojects in this image. By starting up a new XProjectBrowser, the user will get a menu with Xall those names. X'. X XProjectClassHBrowser commentFor: 'changeLog' put: X'Not used yet. Had this idea of keeping a seperate Xchange log file for each project. Not sure if this Xwould be useful for anything. X'. X XProjectClassHBrowser commentFor: 'projectName' put: X'Contains the name of the project we are currently Xworking on. The same name is also displayed in Xthe window header. X'. X X ! XObject subclass: #ClassDocBrowser X instanceVariableNames: X 'class variable ' X classVariableNames: '' X poolDictionaries: ''! X XClassDocBrowser class comment: X'A ClassDocBrowser supports reading and saving Xverbal explanation of the purpose of a class X(stored in the pseudo variable CLASS) and all Xthe instance, class, and pool variables. X'. X XClassDocBrowser commentFor: 'class' put: X'Contains the class we are displaying the Xdocumentation for. X XThe docu text is stored in the instance variable X<comment> in class Behavior. X'. X XClassDocBrowser commentFor: 'variable' put: X'Contains the currently selected variable. X'. X X ! X X!CategorizedClassBrowser class methodsInCategory: 'bugs&info'! X Xauthor X "if you have any complaints, suggestions, or X whatever send me a message under" X ^'ott@piyopiyo.hatori.t.u-tokyo.ac.jp'! X Xbugs X "return string telling you about the known bugs" X ^' XCategorizedClassBrowser: X======================== X X1) If you edit the name of a method and you change X the category, you''ll change the category of the X originally displayed method. This could be prevented X by asking the text pane if it is modified before X changing the category. However, we don''t keep X the name of the text pane around. Would need a new X instance variable and a check to X <textPane dispatcher modified>'! ! X X X!CategorizedClassBrowser methodsInCategory: 'classes'! X XaddSubClass X "Private - Add a subclass to the selected X class. If a class is selected, prompt the X user for a new class name and add it as a X subclass to the selected class." X | newName subclassType answer | X selectedClass isNil X ifTrue: [^self]. X newName := Prompter X prompt: selectedClass name , ' subclass?' X default: ''. X (newName isNil or: [newName isEmpty]) X ifTrue: [^nil]. X (newName at: 1) isUpperCase X ifFalse: [ X newName at: 1 X put: (newName at: 1) asUpperCase]. X newName := newName asSymbol. X (Smalltalk includesKey: newName) X ifTrue: [^self error: newName, ' already exists']. X subclassType := (Menu X labels: 'subclass\variableSubclass\variableByteSubclass' withCrs X lines: Array new X selectors: #(pointer indexed byte)) X popUpAt: Cursor offset. X (subclassType == #pointer and: [selectedClass isVariable]) X ifTrue: [ X (Prompter X prompt: 'Indexed pointer subclass assumed. Confirm (y/n)' X default: (String with: $y)) asLowerCase X = (String with: $y) X ifFalse: [^self]]. X subclassType == #pointer X ifTrue: [ X ((selectedClass subclass: newName X instanceVariableNames: '' X classVariableNames: '' X poolDictionaries: '') X isKindOf: Class) X ifFalse: [^self]]. X subclassType == #indexed X ifTrue: [ X ((selectedClass variableSubclass: newName X instanceVariableNames: '' X classVariableNames: '' X poolDictionaries: '') X isKindOf: Class) X ifFalse: [^self]]. X subclassType == #byte X ifTrue: [ X ((selectedClass variableByteSubclass: newName X classVariableNames: '' X poolDictionaries: '') X isKindOf: Class) X ifFalse: [^self]]. X subclassType isNil ifTrue: [^self]. X selectedClass := Smalltalk at: newName asSymbol. X CursorManager execute change. X selectedMethod := nil. X selectedCategory := nil. X methodSelectedLast := false. X self update: originalClasses. X self X changed: #hierarchy X with: #restoreSelected: X with: ((String new: X (Smalltalk at: newName asSymbol) X allSuperclasses size) X atAllPut: $ ), newName. X self X changed: #categories; X changed: #selectors; X changed: #text! X XfileOut X "Private - Write the source for the selected class X in chunk file format to a file named with the class X name reduced to 8 characters, extension 'cls'." X | aFileStream | X selectedClass isNil X ifTrue: [^self]. X CursorManager execute change. X aFileStream := Disk newFile: X (File X fileName: selectedClass name X extension: (String with: $c with: $l with: $s)). X aFileStream lineDelimiter: 10 asCharacter. X selectedClass fileOutOn: aFileStream. X selectedClass fileOutDocOn: aFileStream. X aFileStream nextChunkPut: String new. X (CategoryClassReader forClass: selectedClass class) X fileOutOnWithCategories: aFileStream. X (CategoryClassReader forClass: selectedClass) X fileOutOnWithCategories: aFileStream. X aFileStream close. X CursorManager normal change! X XgetClass: aString X "private - return the class object described by X aString. If this class is not found, complain X and return nil." X | string aClass | X string := aString. X string last == $. X ifTrue: [ X string := string copyFrom: 1 X to: string size - 3]. X aClass := Smalltalk X at: string trimBlanks asSymbol X ifAbsent: [ X Menu message: 'non-existent class'. X self update. X ^nil]. X ^aClass! X XhideShow X "Private - Change the hide/show X status of the selected class." X selectedClass isNil X ifTrue: [^nil]. X CursorManager execute change. X (hiddenClasses includes: selectedClass) X ifTrue: [ X hiddenClasses remove: selectedClass] X ifFalse: [ X selectedClass subclasses isEmpty X ifFalse: [ X hiddenClasses add: selectedClass]]. X methodSelectedLast := false. X self initSelectedCategory. X selectedMethod := nil. X self X update: originalClasses; X changed: #hierarchy X with: #restoreSelected; X changed: #categories X with: #restoreSelected: X with: selectedCategory; X changed: #selectors; X changed: #text.! X Xhierarchy: aString X "Private - Display the selectors for the X selected class in the selector list pane." X | string aClass | X string := aString. X ( aClass := self getClass: aString) isNil X ifTrue: [ ^self ]. X selectedClassString := aString. X selectedClass == aClass X ifTrue: [^self hideShow]. X methodSelectedLast := false. X selectedMethod := nil. X selectedClass := aClass. X "if there is only one category; select it." X self initSelectedCategory. X selectedCategory isNil X ifTrue: [ "start with the first item" X self changed: #categories X ] X ifFalse: [ X self changed: #categories X with: #restoreSelected: X with: selectedCategory X ]. X self X changed: #selectors; X changed: #text. X self checkCategories.! X XremoveSubClass X "Private - Delete the selected class." X | newName subclassType answer | X selectedClass isNil X ifTrue: [^nil]. X newName := Prompter X prompt: selectedClass name , ' to be deleted? (Y/N)' X default: 'N'. X newName isNil ifTrue: [^nil]. X newName asUpperCase = 'Y' X ifFalse: [^nil]. X selectedClass removeFromSystem. X selectedClass removeAllCategories. X CursorManager execute change. X selectedMethod := nil. X selectedCategory := nil. X methodSelectedLast := false. X self update: originalClasses. X self changed: #hierarchy X with: #restore. X selectedClass := nil. X self X changed: #categories; X changed: #selectors; X changed: #text! X XselectedClass X "private - return the right receiver, X either class or metaclass." X ^instanceSelectedLast X ifTrue: [ selectedClass ] X ifFalse: [ selectedClass class ]! ! X X X!CategorizedClassBrowser methodsInCategory: 'initialize'! X XinitWindowSize X "Private - Answer the initial X window extent." X ^Display width * 3 // 4 @ X (Display height * 5 // 6)! X XopenOn: aCollection X "Create a class hierarchy browser window giving access X to the classes in aCollection and their subclasses." X | aTopPane listLineHeight ratio | X hiddenClasses := Set new. X history := OrderedCollection new: self historyLength. X (aCollection includes: Object) X ifTrue: [ X aCollection do: [ :class | X class subclasses do: [:each | X each subclasses isEmpty X ifFalse: [ X hiddenClasses add: each]]]] X ifFalse: [ X aCollection do: [ :class | X class subclasses isEmpty X ifFalse: [ X hiddenClasses add: class]]]. X ratio := 2 / 5. X self update: aCollection. X listLineHeight := ListFont height + 4. X instanceSelectedLast := true. X methodSelectedLast := false. X aTopPane := TopPane new X model: self; X label: self label; X menu: #topMenu; X minimumSize: 20 * SysFontWidth X @ (10 * SysFontHeight); X rightIcons: #(resize collapse zoom); X foreColor: 0; X backColor: 15; X yourself. X aTopPane addSubpane: X (ListPane new X model: self; X name: #hierarchy; X change: #hierarchy:; X menu: #menu; X framingBlock: [:box| X box origin extent: X (box width * 3 // 9 ) @ X ((box height * ratio) truncated - X listLineHeight)]). X aTopPane addSubpane: X ( ListPane new X model: self; X name: #categories; X change: #category:; X menu: #categoryMenu; X framingBlock: [:box| X box origin + (box width * 3 // 9 @ 0) extent: X (box width * 2 // 9 ) @ X ((box height * ratio) truncated - X listLineHeight)]; X yourself). X aTopPane addSubpane: X (ListPane new X model: self; X name: #selectors; X change: #selector:; X menu: #selectorMenu; X framingBlock: [:box| X box origin + ( box width * 5//9 @ 0) extent: X (box width * 4 + 8 // 9) @ X ((box height * ratio) truncated - X listLineHeight)]). X aTopPane addSubpane: X (ListPane new X model: self; X name: #instances; X change: #instance:; X selection: 1; X framingBlock: [:box| X box origin+ X (box width//2 @ X ((box height * ratio) truncated - X (listLineHeight))) X extent: box width//4 @ X (listLineHeight)]). X aTopPane addSubpane: X (ListPane new X model: self; X name: #classes; X change: #class:; X framingBlock: [:box| X box origin+ X (box width//2+(box width//4) @ X ((box height * ratio) truncated - X (listLineHeight))) X extent: X (box width - (box width//2) - X (box width//4)) @ X (listLineHeight)]). X aTopPane addSubpane: X (ListPane new X model: self; X name: #editedCategory; X change: #suppressChange:; X menu: #changeCategory; X framingBlock: [:box| X box origin+ X (0 @ X ((box height * ratio) truncated - X (listLineHeight))) X extent: box width//2 @ X (listLineHeight)]). X aTopPane addSubpane: X ( TextPane new X model: self; X name: #text; X menu: #textMenu; X change: #accept:from:; X framingRatio: (0 @ (ratio) X corner: 1 @ 1); X yourself). X aTopPane dispatcher open scheduleWindow! ! X X X!CategorizedClassBrowser methodsInCategory: 'test'! X XxTestx X self inspect! ! X X X!CategorizedClassBrowser methodsInCategory: 'text'! X Xaccept: aString from: aDispatcher X "Private - Accept aString as an updated method X or class specification and compile it. Notify X aDispatcher if the compiler detects errors." X | result aClass | X methodSelectedLast X ifFalse: [ X ^self acceptClass: aString from: aDispatcher]. X aClass := instanceSelectedLast X ifTrue: [selectedClass] X ifFalse: [selectedClass class]. X result := self compile: aString X notifying: aDispatcher X in: aClass. X result isNil X ifTrue: [^false] X ifFalse: [ X Smalltalk X logSource: aString X forSelector: result key X inClass: aClass. X self successfulCompiledMethod: result key. X result key == selectedMethod X ifFalse: [ X selectedMethod := result key. X displayedMethod := result key. X self selectedClass X addSelector: result key X category: currentCategory. X selectedCategory := currentCategory. X self addCurrentToHistory. X self X changed: #categories X with: #restoreSelected: X with: selectedCategory; X changed: #selectors X with: #restoreSelected: X with: selectedMethod. X ]. X ^true]! X Xcompile: aString X notifying: aDispatcher X in: aClass X "Private - Accept aString as an updated X method and compile it. Notify aDispatcher X if the compiler detects errors." X | answer oldCursor class category confirm | X oldCursor := Cursor. X CursorManager execute change. X class := self selectedClass. X answer := Compiler X compile: aString X in: class X notifying: aDispatcher X ifFail: [ oldCursor change. ^nil]. X oldCursor change. X category := class category: answer key. X ( category isNil or: [ category = currentCategory ]) X ifFalse: [ X confirm := Prompter X prompt: answer key , ' also in <', category, X '>. overwrite? (Y/N)' X default: 'N'. X confirm isNil ifTrue: [^nil]. X confirm asUpperCase = 'Y' X ifFalse: [^nil]. X class changeCategoryFor: answer key X from: category X to: currentCategory X ]. X class addSelector: answer key withMethod: answer value. X ^ answer! X XstraightTextMenu X "private - ask text pane to pop up normal text menu." X self changed: #text X with: #popUp: X with: TextEditor menu! X XsuccessfulCompiledMethod: aMethod X "private - aMethod has been sucessfully compiled. X Isn't that great. Have a beer."! X Xtext X "Private - Answer the source text for X the selected method or class definition X for the selected class." X selectedClass isNil X ifTrue: [^String new]. X currentCategory := X methodSelectedLast X ifTrue: [ selectedCategory ] X ifFalse: [ nil]. X self changed: #editedCategory. X ^super text.! X XtextMenu X "private - if text pane contains method, return X standard menu. If it shows class description, get X doc menu." X methodSelectedLast X ifTrue: [ ^TextEditor menu ] X ifFalse: [ ^self docMenu ]! ! X X X!CategorizedClassBrowser methodsInCategory: 'history'! X XaddCurrentToHistory X "private - add current selection to the end of the X history queue. If the queue is full, dump the X first item." X selectedMethod isNil ifTrue: [ ^nil ]. X ( history size = self historyLength) X ifTrue: [ history removeFirst ]. X history addLast: X (( Array new: 4) X at: 1 put: selectedClassString; X at: 2 put: selectedCategory; X at: 3 put: selectedMethod; X at: 4 put: instanceSelectedLast; X yourself)! X XgotoClass: aClassString X category: aCategory X method: aMethod X classInstance: aBoolean X "private - display text for aMethod in class X aClass and category aCategory. But before X we change, check if class / instance was X not changed." X"self error: 'goto'. " X aBoolean == instanceSelectedLast X ifFalse: [ self changeClassInstance: aBoolean ]. X selectedClass := self getClass: aClassString. X selectedClassString := aClassString. X selectedCategory := aCategory. X selectedMethod := aMethod. X displayedMethod := aMethod. X methodSelectedLast := true. X self addCurrentToHistory. X self X changed: #text; X changed: #hierarchy X with: #restoreSelected: X with: aClassString; X changed: #categories X with: #restoreSelected: X with: selectedCategory asSymbol; X changed: #selectors X with: #restoreSelected: X with: selectedMethod.! X XhistoryLength X "private - answer the length of the history queue." X ^10! X XshowHistory X "private - pop up a menu with the last n selected X methods." X | labels selector index selected size | X size := history size. X labels := OrderedCollection new: size. X history do: [ :anArray | X ( selector := anArray at: 3) isNil X ifFalse: [ labels addLast: selector asString ] X ]. X selectedMethod isNil "don't display current selected" X ifFalse: [ labels removeLast ]. X index := ( Menu X labelArray: labels X lines: Array new X selectors: ( 1 to: labels size)) X popUpAt: Cursor offset. X index isNil ifTrue: [ ^nil ]. X selected := history asArray at: index. X self gotoClass: ( selected at: 1) X category: ( selected at: 2) X method: ( selected at: 3) X classInstance: ( selected at: 4)! ! X X X!CategorizedClassBrowser methodsInCategory: 'category'! X XaddCategory X "Private - Add a new category." X | newCategory | X selectedClass isNil X ifTrue: [^self]. X newCategory := Prompter X prompt: selectedClass name , ' new category?' X default: ''. X newCategory isEmpty X ifTrue: [ ^self ]. X self selectedClass X addCategory: newCategory asSymbol. X selectedCategory := newCategory asSymbol. X self X changed: #categories X with: #restoreSelected: X with: selectedCategory asSymbol; X changed: #selectors! X Xcategories X "Private - Answer a sorted list of categories X for the selected class." X | selectors categories | X selectedClass isNil X ifTrue: [^Array new]. X ^self selectedClass allCategories keys asSortedCollection! X Xcategory: aSymbol X "Private - Display the methods for this new X category." X selectedCategory := aSymbol asSymbol. X selectedMethod := nil. X "methodSelectedLast := false." X self changed: #selectors! X XcategoryMenu X "Private - Answer the category pane menu." X ^Menu X labels: 'check\remove\rename\add\test' withCrs X lines: #(1 4) X selectors: #(checkCategories removeCategory renameCategory addCategory xTestx)! X XchangeCategory X "change the category of the currently displayed X method. Display a list of all the defined X categories." X | categories newCategory | X " currentCategory isNil no method displayed X ifTrue: [ Terminal bell. ^nil ]. " X categories := self categories asArray. X newCategory := X (Menu X labelArray: categories X lines: Array new X selectors: categories) X popUpAt: Cursor position. X ( newCategory isNil X or: [ newCategory = currentCategory]) X ifFalse: [ X displayedMethod isNil X ifFalse: [ X self selectedClass X changeCategoryFor: displayedMethod X from: currentCategory X to: newCategory. X currentCategory := newCategory. X self X changed: #selectors; X changed: #editedCategory. X ] X ifTrue: [ X Menu message: X 'sorry, but you have to select method too'. X ] X ]. X ^nil! X XcheckCategories X "Just to be sure. Check stored categories for double entries X or selectors without categories. X In case of a double entry, keep one and throw away the rest. X Very simple. Too simple? Should not happen anyway. X In case of no category, create xERRORx category and throw X it in there. In this case update the category pane." X | errorSet | X selectedClass isNil X ifTrue: [^self]. X errorSet := self selectedClass checkCategories. X errorSet isEmpty X ifFalse: [ X selectedCategory := #xERRORx. X self selectedClass X addCategory: selectedCategory. X errorSet do: [ :selector | X self selectedClass X addSelector: selector X category: selectedCategory X ]. X self X changed: #categories X with: #restoreSelected: X with: selectedCategory; X changed: #selectors X ].! X XeditedCategory X "Private - Return the category of the X currently displayed method." X currentCategory isNil X ifTrue: [^Array new]. X ^( Array with: 'category: ', currentCategory) asSortedCollection! X XinitSelectedCategory X "private - if there is only one category X select it straight away and show its X selectors, otherwise set selectedCategory X to nil." X | dict | X dict := self selectedClass allCategories. X dict size = 1 X ifFalse: [ ^selectedCategory := nil ]. X "a strange way to get the only category" X dict keys do: [ :k | selectedCategory := k ].! X XremoveCategory X "private - Delete selected category. But only if it X does not contain any methods." X self selectors size = 0 X ifFalse: [ ^Menu message: 'Remove methods first!!']. X self selectedClass removeCategory: selectedCategory. X selectedCategory := nil. X self changed: #categories! X XrenameCategory X "Private - Rename selected category." X | newName | X ( selectedClass isNil or: [ selectedCategory isNil ]) X ifTrue: [^self]. X newName := Prompter X prompt: ' rename category: ', selectedCategory printString X default: selectedCategory printString. X ( newName isEmpty or: [ newName asSymbol = selectedCategory ]) X ifTrue: [ ^self ]. X self selectedClass X renameCategoryFrom: selectedCategory to: newName asSymbol. X selectedCategory := newName asSymbol. X self changed: #categories X with: #restoreSelected: X with: selectedCategory.! X XsuppressChange: aSymbol X "private - the currentCategory pane got X selected. Re-reverse the pane." X self changed: #editedCategory! ! X X X!CategorizedClassBrowser methodsInCategory: 'instanceClass'! X XchangeClassInstance: aBoolean X "private - if aBoolean is false change to class X method display, otherwise change to instance display." X aBoolean X ifTrue: [ X self X changed: #classes; X changed: #instances X with: #restoreSelected: X with: 1 X ] X ifFalse: [ X self X changed: #instances; X changed: #classes X with: #restoreSelected: X with: 1 X ]. X instanceSelectedLast := aBoolean! X Xclass: aSymbol X "Private - Change the state of the browser X so that class messages are selected." X instanceSelectedLast := methodSelectedLast := false. X self initSelectedCategory. X self X changed: #categories X with: #restoreSelected: X with: selectedCategory; X changed: #instances; X changed: #selectors; X changed: #text. X self checkCategories.! X Xinstance: aSymbol X "Private - Change the state of the browser X so that instance messages are selected." X instanceSelectedLast := true. X methodSelectedLast := false. X self initSelectedCategory. X self X changed: #categories X with: #restoreSelected: X with: selectedCategory; X changed: #classes; X changed: #selectors; X changed: #text. X self checkCategories.! ! X X X!CategorizedClassBrowser methodsInCategory: 'classDoc'! X XdocMenu X "private - return menu to either edit the class X description or display class documentation." X ^Menu X labels: 'documentation\edit' withCrs X lines: Array new X selectors: #(openDoc straightTextMenu)! X XopenDoc X "Open a pane for viewing and editing the X class and variable documentation." X ClassDocBrowser new openFor: selectedClass! ! X X X!CategorizedClassBrowser methodsInCategory: 'selectors'! X XnewMethod X "Private - Display the text for a new X method template in the text pane. X Ask for category if none is selected" X selectedClass isNil X ifTrue: [self error: 'no class selected']. X selectedCategory isNil X ifTrue: [ X self categories size = 0 X ifTrue: [ self addCategory ] X ]. X selectedCategory isNil X ifTrue: [ ^Menu message: 'select category first' ]. X ^super newMethod! X XremoveSelector X "Private - Remove the selected method." X | aString | X methodSelectedLast X ifFalse: [^nil]. X selectedMethod isNil X ifTrue: [^nil]. X self selectedClass X removeSelector: selectedMethod X category: selectedCategory. X ^super removeSelector! X Xselector: aSymbol X "Private - Display the selected X method in the text pane." X super selector: aSymbol. X displayedMethod := aSymbol. X self addCurrentToHistory.! X XselectorMenu X "Private - Answer the selector pane menu." X ^Menu X labels: 'remove\new method\senders\implementors\history' withCrs X lines: ( Array with: 4 ) X selectors: #(removeSelector newMethod senders implementors showHistory)! X Xselectors X "Private - Answer a sorted list of method X selectors for the selected class and X dictionary type (class or instance)." X ( selectedClass isNil or: [ selectedCategory isNil]) X ifTrue: [^Array new]. X ^(self selectedClass X selectorsForCategory: selectedCategory) X asSortedCollection! ! X X X!CategorizedClassBrowser methodsInCategory: 'window'! X XcollapsedLabel X "Private - Answer the X collapsed label." X ^' CCHB '! X Xlabel X "Private - Answer the window label." X ^'CClass Hierarchy Browser'! X XtopMenu X "private - return menu for the top pane. X For this application return standard one." X ^TopDispatcher menu! ! X X X!Class methodsInCategory: 'etc'! X XfileOutDocOn: aStream X "Append the class documentation X for the receiver to aStream. X!!!!!! max" X | aString | X aStream X nextPut: $!!; "this should force the compiler X to introduce the class, before X we add the documentation." X cr; cr; X nextPutAll: self printString; space; X nextPutAll: 'class comment: '; cr; X nextPutAll: self class comment storeString, '.'; cr; cr. X X self comment keysValuesDo: [ :var :text | X aStream X nextPutAll: self printString; space; X nextPutAll: 'commentFor: ', var storeString, ' put:'; cr; X nextPutAll: text storeString; X nextPutAll: '.'; cr; cr X ]! ! X X X!Behavior methodsInCategory: 'comment'! X XcommentFor: aVariable X "return comment for aVariable X!!!!!! max" X comment isNil X ifTrue: [ X ^'not documented' X ]. X ^comment at: aVariable ifAbsent: [ 'not documented' ]! X XcommentFor: aVariable put: aString X "store comment aString for aVariable X!!!!!! max" X comment isNil X ifTrue: [ X comment := Dictionary new X ]. X ^comment at: aVariable put: aString! ! X X X!Behavior methodsInCategory: 'etc'! X XaddCategory: aCategory X "add a new category to the this class. X!!!!!! max." X | categories | X categories := self allCategories. X categories at: aCategory X ifAbsent: [ categories at: aCategory put: Set new ]! X XcategoryFor: aSelector X "return the category of aSelector. X!!!!!! max" X self allCategories keysValuesDo: [ :aCategory :aSet | X ( aSet detect: [ :sample | sample = aSelector ] X ifNone: [ nil ]) X isNil X ifFalse: [ ^aCategory ] X ]. X "can't find a category. Check if selector is still X around." X self selectors detect: [ :anotherSelector | X aSelector == anotherSelector X ] X ifNone: [ ^nil ]. "has been removed" X Menu message: 'check categories in class <', name, '>'. X ^#etc! ! X X X!ProjectClassHBrowser class methodsInCategory: 'initialize'! X Xinitialize X "initialize the class variables. X Projects holds a dictionary with a key for X each project." X Projects := Dictionary new.! X Xinstall X "install the project browser in screen menu." X X ( ReadStream on: '!! ScreenDispatcher methods !! XopenClassBrowser X "Private - Open a class hierarchy browser." X ProjectClassHBrowser new X openOn: (Array with: Object) !! !!') X fileIn! ! X X X!ProjectClassHBrowser class methodsInCategory: 'inquire'! X Xprojects X "return a dictionary containing all X projects." X ^Projects! ! X X X!ProjectClassHBrowser class methodsInCategory: 'bugs&info'! X Xbugs X "return string telling you about the known bugs" X ^' XProjectClassHBrowser: X===================== X X1) There is no way yet to add methods to a project when installing X them from a file. Need some class methods like X ProjectClassHBrowser project:addMethod: X Maybe this should go in a seperate class anyway. X X2) At the moment you can''t remove a method from a project, except X by editing X (ProjectClassHBrowser projects at:#project) inspect X X3) For no particular reason the instance variable holding X all the changes is called changeDirectory. Why ..Directory? X Because it is a Dictionary. Reason enough? X X ', super bugs! ! X X X!ProjectClassHBrowser methodsInCategory: 'selectors'! X XremoveSelector X "Private - Remove the selected method. X Also remove it from the project directory." X | tmp | X methodSelectedLast X ifFalse: [^nil]. X selectedMethod isNil X ifTrue: [^nil]. X tmp := self classChangeDirectory. X ( instanceSelectedLast X ifTrue: [ tmp at: 1 ] X ifFalse: [ tmp at: 2 ] ) X remove: selectedMethod ifAbsent:[]. X ^super removeSelector! X XselectorMenu X "Private - Answer the selector pane menu." X ^Menu X labels: 'remove\new method\senders\implementors\add to project\history' withCrs X lines: ( Array with: 4 ) X selectors: #(removeSelector newMethod senders implementors addCurrentToProject showHistory)! ! X X X!ProjectClassHBrowser methodsInCategory: 'initialize'! X XopenOn: aCollection X "Create a class hierarchy browser window giving access X to the classes in aCollection and their subclasses. X There is a project name associated with this window. X Therefore we also keep a diary of all the methods X changed while working on this project. Later we X can ask to file out all the changed methods." X | newName | X Projects isNil ifTrue: [ ProjectClassHBrowser initialize ]. X newName := self askForProjectName. X newName isNil ifTrue: [ ^nil ]. X changeDirectory := X ( Projects at: newName X ifAbsent: [ Projects at: newName X put: Dictionary new X ]). X projectName := newName. X ^super openOn: aCollection! ! X X X!ProjectClassHBrowser methodsInCategory: 'project'! X XaddCurrentToProject X "private - add current selected method to X project log." X self addMethodToProject: selectedMethod! X XaddMethodToProject: aMethod X "private - add aMethod to the project log." X | tmp | X tmp := self classChangeDirectory. X instanceSelectedLast X ifTrue: [( tmp at: 1) add: aMethod ] X ifFalse: [( tmp at: 2) add: aMethod ]! X XaskForProjectName X "private - ask user for new project name. X Set variable projectName accordingly. X First display a menu with all known X projects. For new projects click the last X menu line which will open a prompter to X input the proper name. Return the new selected X project name or nil if none was selected." X | names index newName | X names := Projects keys asOrderedCollection. X names size = 0 X ifTrue: [ index := 0 ] X ifFalse: [ X names addLast: '>> New Project?'. X names := names asArray. X index := ( Menu X labelArray: names X lines: Array new X selectors: ( 1 to: names size)) X popUpAt: Cursor offset. X index isNil ifTrue: [ ^nil ] X ]. X index = names size X ifTrue: [ "get new name" X newName := Prompter X prompt: ' Project name?' X default: ''. X newName isEmpty ifTrue: [ ^nil ]. X ] X ifFalse: [ X newName := names at: index X ]. X ^newName! X XchangeProjectName X "private - ask user for a different name X for the current project. X update label. X!!!!!! Don't know how to update collapsed label" X | newName | X ( newName := self typeNewProjectName) isNil X ifTrue: [ ^nil ]. X ( Projects at: newName ifAbsent: [ nil ]) isNil X ifFalse: [ X ^Menu message: '<', newName, X '> is used for a different project' X ]. X Projects at: newName X put: ( Projects at: projectName). X Projects removeKey: projectName. X projectName := newName. X self changed: #label! X XclassChangeDirectory X "private - return an array for the selected class X for adding new methods to change log. This array is X stored in class variable Projects. X X The changeDirectory is the value of the dictionary X entry for this project in the class variable Class. X It is a dictionary with a key for each class changes X have been made. For each class a array of 2 sets X is kept, for instance methods and class methods X respectively. X We also set a flag if the class specifications X were changed." X changeDirectory at: selectedClass X ifAbsent: [ X changeDirectory at: selectedClass X put: ( Array with: Set new with: Set new with: false) ]. X ^changeDirectory at: selectedClass! X XfileOutProject X "private - file out all the methods and X class definitions changed or created while X developing of this project." X | aFileStream | X changeDirectory isNil X ifTrue: [^self]. X CursorManager execute change. X aFileStream := Disk newFile: X (File X fileName: projectName X extension: (String with: $c with: $l with: $s)). X aFileStream lineDelimiter: 10 asCharacter. X self fileOutProjectHeaderOn: aFileStream. X "first file out all the headers of all newly created X classes to avoid references to a class before the X new image knows about them." X changeDirectory keysValuesDo: [ :aClass :changeArray | X ( changeArray at: 3) "class was newly created" X ifTrue: [ X aClass fileOutOn: aFileStream. X aClass fileOutDocOn: aFileStream. X aFileStream nextChunkPut: String new. X ] X ]. X changeDirectory keysValuesDo: [ :aClass :changeArray | X ( changeArray at: 2) size == 0 "file out class definitions" X ifFalse: [ X ( CategoryClassReader forClass: aClass class) X fileOutOnWithCategories: aFileStream X selection: ( changeArray at: 2). X ]. X ( changeArray at: 1) size == 0 "file out methods" X ifFalse: [ X ( CategoryClassReader forClass: aClass ) X fileOutOnWithCategories: aFileStream X selection: ( changeArray at: 1). X ]. X ]. X aFileStream close. X CursorManager normal change! X XfileOutProjectHeaderOn: aFileStream X "private - write some information on the X current project at the beginning of the X file." X aFileStream X nextPutAll: '"****************************'; cr; X nextPutAll: ' * ', ( Date dateAndTimeNow at: 1) printString, ' ', X ( Date dateAndTimeNow at: 2) printString; cr; X nextPutAll: ' *'; cr; X nextPutAll: ' * Project: ', projectName; cr; X nextPutAll: ' *'; cr; cr; X nextPutAll: ' (Disk file: ''', X (File fileName: projectName extension: 'cls'), X ''') fileIn; close.'; cr; X nextPutAll: '"'; nextPut: $!!; cr.! X XtopMenu X | selection | X ^Menu X labels: 'change name\file out' withCrs X lines: #() X selectors: #(changeProjectName fileOutProject)! X XtypeNewProjectName X "private - ask user with a prompter for X a new project name and return this name." X | newName | X newName := Prompter X prompt: ' Project name?' X default: ''. X newName isEmpty ifTrue: [ ^nil ]. X ^newName! ! X X X!ProjectClassHBrowser methodsInCategory: 'text'! X XsuccessfulCompiledMethod: aMethod X "private - aMethod has been sucessfully compiled. X Isn't that great. Have a beer. X Also add it to the project log." X self addMethodToProject: aMethod! ! X X X!ProjectClassHBrowser methodsInCategory: 'classes'! X XacceptClass: aString from: aDispatcher X "Private - Accept aString as an updated X class specification and compile it. Notify X aDispatcher if the compiler detects errors." X | result | X result := Compiler X evaluate: aString X in: nil class X to: nil X notifying: aDispatcher X ifFail: [^false]. X Smalltalk logEvaluate: aString. X self classSpecificationsHaveChanged. X ^(result isKindOf: Class)! X XclassSpecificationsHaveChanged X "private - mark in project log that X the specifications for the currently X selected class have changed." X self classChangeDirectory at: 3 put: true! ! X X X!ProjectClassHBrowser methodsInCategory: 'window'! X XcollapsedLabel X "Private - Answer the X collapsed label." X ^'<', projectName, '>'! X Xlabel X "Private - Answer the window label." X ^'Project: <', projectName, '>'! ! X X X!CategoryClassReader methodsInCategory: 'inOut'! X XinstanceHeaderOn: aStream category: aCategory X "Private - Write a header to aStream which identifies X the class described by the receiver. The header X precedes the source code for the methods. X Add category too." X aStream X cr; X nextPut: $!!; X nextPutAll: class name; X space; X nextPutAll: 'methodsInCategory: '; X nextPutAll: aCategory asString printString; X nextPut: $!!! X XsortIntoCategories: aSet X "private - put all the methods in aSet into X a dictionary where the key is the category X and the value is a set containing all the methods X belonging to the same category." X | dictionary category | X dictionary := Dictionary new. X aSet do: [ :aSelector | X ( category := class categoryFor: aSelector) isNil X ifFalse: [ "ok found a category for it" X dictionary at: category X ifAbsent: [ dictionary at: category put: Set new ]. X ( dictionary at: category) add: aSelector. X ] X ]. X ^dictionary! ! X X X!ClassDocBrowser methodsInCategory: 'initialize'! X XdocTextInit X "private - show the class docu immediatly" X | comment | X variable := 'CLASS'. X self changed: #variables X with: #selection: with: 1. X (comment := class class comment) isNil X ifTrue: [ ^'not documented' ] X ifFalse: [ ^comment ]! X XinitWindowSize X "Answer the initial window extent." X ^Display width * 4 // 5 @ X (Display height // 2)! X XopenFor: aClass X "Open a pane for viewing and editing the X class and variable documentation." X | aTopPane | X class := aClass. X aTopPane := TopPane new X model: self; X label: 'doc: ', class name; X minimumSize: SysFontWidth * 20 X @ (SysFontHeight * 8); X yourself. X aTopPane addSubpane: X (ListPane new X model: self; X name: #variables; X change: #variable:; X " X menu: #selectorMenu; X " X framingRatio: (0@0 extent: 1/5@1)). X aTopPane addSubpane: X (TextPane new X model: self; X name: #docText; X change: #docChange:from:; X framingRatio: (1/5@0 extent: 4/5@1)). X aTopPane dispatcher open scheduleWindow! X Xvariables X "private - return an array with all the instance X and class variables." X | list | X list := OrderedCollection new. X list addLast: 'CLASS'. X class instanceVariableString asArrayOfSubstrings do: [ :l | X list addLast: l X ]. X class classVariableString asArrayOfSubstrings do: [ :l | X list addLast: l X ]. X ^list asArray! ! X X X!ClassDocBrowser methodsInCategory: 'work'! X XdocChange: aString from: aDispatcher X "private - accept a new docu string. Store it X in Behavior. CLASS docu in class class comment, X variables in class comment as dictionary." X | dict | X variable = 'CLASS' X ifTrue: [ "get class docu" X class class comment: aString X ] X ifFalse: [ "write variable docu" X class commentFor: variable put: aString X ]. X ^true! X XdocText X "return comment for selected variable." X | comment dict | X variable isNil X ifTrue: [ ^self docTextInit ]. X variable = 'CLASS' X ifTrue: [ "get class docu" X (comment := class class comment) isNil X ifTrue: [ ^'not documented' ] X ifFalse: [ ^comment ] X ] X ifFalse: [ "get variable docu" X ^class commentFor: variable X ]. X ^'strange ERROR'! X Xvariable: aString X "private - a new variable got selected; display X its documentation." X variable := aString. X self changed: #docText.! ! ________This_Is_The_END________ if test `wc -c < prjct_br.cls` -ne 48521; then echo 'shar: prjct_br.cls was damaged during transit (should have been 48521 bytes)' fi fi ; : end of overwriting check exit 0