"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
StandardSystemView subclass:#BrowserView
instanceVariableNames:'classCategoryListView classListView methodCategoryListView
methodListView classMethodListView codeView classToggle
instanceToggle currentClassCategory currentClassHierarchy
currentClass currentMethodCategory currentMethod currentSelector
showInstance actualClass fullClass lastMethodCategory aspect
variableListView fullProtocol lockUpdates autoSearch myLabel
acceptClass lastSourceLogMessage lastCategory lastModule
lastPackage'
classVariableNames:'CheckForInstancesWhenRemovingClasses RememberAspect DefaultIcon
StopIcon TraceIcon'
poolDictionaries:''
category:'Interface-Browsers'
!
!BrowserView class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
this class implements all kinds of class browsers.
Typically, it is started with 'SystemBrowser open', but there are many other
startup messages, to launch special browsers.
See the categories 'startup' and 'special search startup' in the classes
protocol.
Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc
for how to use the browser.
written winter 89 by claus
Notice: SystemBrowser is currently being rewritten to be an instance
of ApplicationModel - this transition is not yet complete and you see
here intermediate versions of BrowserView/SystemBrowser.
All action is (currently) still done here in BrowserView, although the
SystemBrowsers class methods are used to startup a browser.
This will certainly change ...
[author:]
Claus Gittinger
"
! !
!BrowserView class methodsFor:'initialization'!
initialize
"Browser configuration;
(values can be changed from your private startup file)"
"
setting this to false, the removeClass function will remove
classes WITHOUT checking for instances. Otherwise,
it will check and let you confirm in case there are instances.
Checking for instances may be a bit time consuming, though.
The default is true - therefore, it will check
"
CheckForInstancesWhenRemovingClasses := true.
"
setting this to true makes the browser remember the aspect shown
in the classList and show this aspect when a new class is selected.
If false, it always switches to the classes definition
"
RememberAspect := true.
"
CheckForInstancesWhenRemovingClasses := true
CheckForInstancesWhenRemovingClasses := false
RememberAspect := true
RememberAspect := false
"
"Created: 23.11.1995 / 11:35:58 / cg"
"Modified: 23.11.1995 / 11:36:34 / cg"
! !
!BrowserView class methodsFor:'cleanup'!
lowSpaceCleanup
DefaultIcon := nil
"Created: 18.4.1996 / 16:46:40 / cg"
! !
!BrowserView class methodsFor:'defaults'!
defaultIcon
DefaultIcon isNil ifTrue:[
DefaultIcon := Form fromFile:'SBrowser.xbm' resolution:100
].
^ DefaultIcon
! !
!BrowserView methodsFor:'change & update'!
refetchClass
"after a class definition change in another browser,
this is sent to update (otherwise, we'd still refer to the obsolete class)"
"/ currentClass := Smalltalk at:(currentClass name asSymbol).
self switchToClass:(Smalltalk at:(currentClass name asSymbol)).
"/ showInstance ifTrue:[
"/ actualClass := currentClass
"/ ] ifFalse:[
"/ actualClass := currentClass class
"/ ].
"Created: 8.2.1996 / 13:22:27 / cg"
"Modified: 8.2.1996 / 13:40:18 / cg"
!
update:something with:someArgument from:changedObject
|list selector oldMethod|
(changedObject == ObjectMemory) ifTrue:[
(something == #earlyRestart
or:[something == #restarted
or:[something == #returnFromSnapshot]]) ifTrue:[
"/ those are to be ignored.
^ self
]
].
"
avoid update/warn after my own changes
"
lockUpdates == true ifTrue:[
"/ 'ignored my change' printNL.
^ self
].
"/ changedObject print. ' ' print. someArgument print. ' ' print.
"/ something printNL.
(changedObject == Smalltalk) ifTrue:[
something == #newClass ifTrue:[
(currentClass notNil
and:[someArgument name = currentClass name]) ifTrue:[
"
the current class was autoloaded
"
self warnLabel:'the selected class has changed'.
self updateClassListWithScroll:false.
].
((someArgument category = currentClassCategory)
or:[currentClassCategory notNil
and:[currentClassCategory startsWith:'*']]) ifTrue:[
self updateClassListWithScroll:false.
].
someArgument category ~= currentClassCategory ifTrue:[
"
category new ?
"
(classCategoryListView notNil
and:[(list := classCategoryListView list) notNil
and:[(list includes:someArgument category) not]])
ifTrue:[
self updateClassCategoryListWithScroll:false.
]
].
^ self
].
something == #classRemove ifTrue:[
someArgument == currentClass ifTrue:[
self warnLabel:'the selected class was removed'.
^ self
].
" fall into general update "
].
"
any other (unknown) change
with the Smalltalk dictionary ...
"
self updateClassCategoryListWithScroll:false.
self updateClassListWithScroll:false.
^ self
].
changedObject isBehavior ifTrue:[
"/
"/ its a class, that has changed
"/
fullClass ifTrue:[
"/
"/ full-class browser ...
"/ (must check for both class and metaclass changes)
"/
(currentClass == changedObject
or:[currentClass class == changedObject]) ifTrue:[
self warnLabel:'class was changed - the code shown may be obsolete'.
].
^ self
].
(currentClass notNil
and:[changedObject name = currentClass name]) ifTrue:[
"/
"/ its the current class that has changed
"/
something == #methodDictionary ifTrue:[
"/ new feature: changeArg may be an array consisting of
"/ the selector and the oldMethod
someArgument isArray ifTrue:[
oldMethod := someArgument at:2.
selector := someArgument at:1.
] ifFalse:[
selector := someArgument
].
(selector isSymbol) ifTrue:[
|changedMethod s1 s2|
"
the method with selector was changed or removed
"
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
selector == currentSelector ifTrue:[
"
special care here: the currently shown method has been
changed somehow in another browser (or via fileIn)
"
changedMethod := currentClass compiledMethodAt:currentSelector.
changedMethod isNil ifTrue:[
self warnLabel:'the method shown was removed'.
^ self
].
"compare the source codes"
currentMethod notNil ifTrue:[
s1 := changedMethod source asString asCollectionOfLines copy.
[s1 last isEmpty] whileTrue:[s1 removeLast].
s2 := codeView contents asCollectionOfLines copy.
[s2 last isEmpty] whileTrue:[s2 removeLast].
s1 = s2 ifFalse:[
self warnLabel:'method has changed - the code shown may be obsolete'.
]
].
^ self
].
]
].
something == #comment ifTrue:[
"
the class has changed its comment; we dont care, except if
currently showing the comment
"
aspect == #comment ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the comment has changed - reselect to update'.
]
].
self refetchClass.
^ self
].
something == #definition ifTrue:[
"
the class has changed its definition.
Warn, except if showing a method.
"
aspect notNil ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the classes definition has changed - reselect to update'.
].
^ self
].
].
"/
"/ if I am not showing code update if unmodified,
"/ warn if modified
"/
aspect notNil ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the classes has changed - reselect to update'.
].
^ self
].
"
get the class again - in case of a changed class definition,
we are otherwise refering to the obsolete old class
"
self refetchClass.
self updateMethodCategoryListWithScroll:false.
"dont update codeView ...."
"self update"
self warnLabel:'the class has changed'.
^ self
].
"
any other class has changed (but not its organization, since
that is cought in the above case).
We are not interested in it - except, if showing fullProtocol
or hierarchy ...
"
currentClassHierarchy notNil ifTrue:[
fullProtocol ifTrue:[
(currentClass isSubclassOf:changedObject) ifTrue:[
self warnLabel:'some superclass has changed - reselect to update'.
]
] ifFalse:[
((currentClass isSubclassOf:changedObject)
or:[changedObject isSubclassOf:currentClass]) ifTrue:[
self warnLabel:'some superclass has changed - reselect to update'.
]
]
].
^ self
].
(changedObject isMethod) ifTrue:[
]
"Modified: 22.10.1996 / 19:27:18 / cg"
! !
!BrowserView methodsFor:'class category list menu'!
classCategoryClone
"open a new SystemBrowser showing the same method as I do"
SystemBrowser openInClass:actualClass selector:currentSelector
"Created: 14.9.1995 / 10:55:20 / claus"
"Modified: 14.9.1995 / 10:59:31 / claus"
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
|aStream fileName|
self checkClassCategorySelected ifFalse:[^ self].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
self withWaitCursorDo:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
self busyLabel:'saving existing %1' with:fileName.
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
self warn:'cannot create: %1' with:fileName
] ifFalse:[
self busyLabel:'writing: %1' with:fileName.
Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
aClass isPrivate ifFalse:[
self busyLabel:'writing: %1' with:fileName.
aClass fileOutOn:aStream.
]
].
aStream close.
]
].
self normalLabel.
"Modified: 14.10.1996 / 20:15:45 / cg"
!
classCategoryFileOutBinaryEach
"fileOut each class in the current category as binary bytecode."
|mode|
mode := Dialog choose:(resources string:'save including sources ?')
labels:(resources array:#('cancel' 'discard' 'by file reference' 'include source'))
values:#(nil #discard #reference #keep)
default:#keep.
mode isNil ifTrue:[^ self].
self withWaitCursorDo:[
Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |
aClass isPrivate ifFalse:[
self busyLabel:'saving binary of: %1' with:aClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
aClass binaryFileOutWithSourceMode:mode.
]
]
].
self normalLabel.
]
"Created: 25.1.1996 / 17:27:45 / cg"
"Modified: 14.10.1996 / 20:14:42 / cg"
!
classCategoryFileOutEach
self withWaitCursorDo:[
Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |
aClass isPrivate ifFalse:[
self busyLabel:'saving: %1' with:aClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot fileOut: %1\(%2)' with:aClass name with:ex errorString.
ex return.
] do:[
aClass fileOut
]
]
].
self normalLabel.
]
"Modified: 14.10.1996 / 20:14:23 / cg"
!
classCategoryFindClass
self classCategoryFindClassOpen:false
"Modified: 1.6.1996 / 16:03:12 / cg"
!
classCategoryFindClassOpen:doOpen
"common code for both opening a new browser on a class and
to search for a class in this browser"
|box openButton title open okText okText2|
open := doOpen.
open ifTrue:[
title := 'class to browse:'.
okText := 'open'.
okText2 := 'find here'.
] ifFalse:[
title := 'class to find:'.
okText := 'find'.
okText2 := 'open new'.
].
box := self enterBoxForCodeSelectionTitle:title okText:okText.
box label:'Class name entry'.
openButton := box addButton:(Button label:(resources string:okText2)) before:(box okButton).
openButton action:[
open := open not.
box doAccept.
box okPressed.
].
box entryCompletionBlock:[:contents |
|s what m|
s := contents withoutSpaces.
what := Smalltalk classnameCompletion:s.
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
self beep
]
].
box action:[:aString |
|brwsr|
open ifTrue:[
brwsr := SystemBrowser open
] ifFalse:[
brwsr := self
].
brwsr switchToClassNameMatching:aString
].
box showAtPointer
"Created: 1.6.1996 / 16:03:15 / cg"
"Modified: 1.6.1996 / 16:15:51 / cg"
!
classCategoryFindMethod
|box|
box := self listBoxForCodeSelectionTitle:'selector to find:' okText:'find'.
box entryCompletionBlock:[:contents |
|s what m|
s := contents withoutSpaces.
box topView withWaitCursorDo:[
what := Smalltalk selectorCompletion:s.
box list:(what at:2).
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
self beep
]
]
].
box action:[:aString | self switchToAnyMethod:aString].
box showAtPointer
"Modified: 30.8.1995 / 22:49:49 / claus"
"Modified: 28.5.1996 / 16:54:35 / cg"
!
classCategoryMenu
<resource: #keyboard ( #Find ) >
|specialMenu m labels selectors shorties|
currentClassCategory notNil ifTrue:[
labels := #(
'fileOut each binary ...'
'-'
'repository history ...'
'-'
'checkin each ...'
).
selectors := #(
classCategoryFileOutBinaryEach
nil
classCategoryRepositoryHistory
nil
classCategoryCheckinEach
).
] ifFalse:[
labels := #(
'repository history ...'
).
selectors := #(
classCategoryRepositoryHistory
).
].
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self.
Smalltalk sourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classCategoryRepositoryHistory
classCategoryCheckinEach).
].
device ctrlDown ifTrue:[
^ specialMenu
].
currentClassCategory isNil ifTrue:[
labels := #(
"/ 'namespace ...'
"/ '-'
'clone'
'open for class ...'
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
'='
'others ...'
).
selectors := #(
"/ namespaceDialog
"/ nil
classCategoryClone
classCategoryOpenInClass
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
nil
otherMenu
).
shorties := #(
"/ nil
"/ nil
nil
nil
nil
nil
Find
nil
nil
nil
nil
#'Ctrl'
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut each'
'printOut'
'printOut protocol'
'-'
"/ 'namespace ...'
"/ '-'
'clone'
'open for class ...'
'SPAWN_CATEGORY'
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
'rename ...'
'remove'
'='
'others'
).
selectors := #(
classCategoryFileOut
classCategoryFileOutEach
classCategoryPrintOut
classCategoryPrintOutProtocol
nil
"/ namespaceDialog
"/ nil
classCategoryClone
classCategoryOpenInClass
classCategorySpawn
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
classCategoryRename
classCategoryRemove
nil
otherMenu
).
shorties := #(
nil
nil
nil
nil
nil
"/ nil
"/ nil
nil
nil
nil
nil
nil
nil
Find
nil
nil
nil
nil
nil
nil
#'Ctrl'
).
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
m subMenuAt:#otherMenu put:specialMenu.
^ m
"Created: 14.9.1995 / 10:50:17 / claus"
"Modified: 26.10.1996 / 14:25:36 / cg"
!
classCategoryNewCategory
|box|
box := self enterBoxTitle:'name of new class category:' okText:'create'.
box action:[:aString |
|categories|
categories := classCategoryListView list.
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
classCategoryListView setContents:categories.
].
currentClassCategory := aString.
classCategoryListView setSelectElement:aString.
self switchToClass:nil.
actualClass := acceptClass := nil.
self classCategorySelectionChanged
].
box showAtPointer
"Modified: 26.5.1996 / 15:02:33 / cg"
"Modified: 19.8.1996 / 18:25:41 / stefan"
!
classCategoryOpenInClass
self classCategoryFindClassOpen:true
"Modified: 1.6.1996 / 16:03:30 / cg"
!
classCategoryPrintOut
|printStream|
Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |
printStream := Printer new.
aClass printOutOn:printStream.
printStream close
]
!
classCategoryPrintOutProtocol
|printStream|
Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
printStream := Printer new.
aClass printOutProtocolOn:printStream.
printStream close
]
!
classCategoryRemove
"remove all classes in current category"
|count t classesToRemove subclassesRemoved box t2|
self checkClassCategorySelected ifFalse:[^ self].
classesToRemove := IdentitySet new.
Smalltalk allBehaviorsDo:[:aClass |
aClass category = currentClassCategory ifTrue:[
classesToRemove add:aClass
]
].
subclassesRemoved := IdentitySet new.
classesToRemove do:[:aClass |
aClass allSubclassesDo:[:aSubclass |
(classesToRemove includes:aSubclass) ifFalse:[
(subclassesRemoved includes:aSubclass) ifFalse:[
subclassesRemoved add:aSubclass
]
]
]
].
count := classesToRemove size.
t := resources string:'remove "%1" ?' with:currentClassCategory.
count ~~ 0 ifTrue:[
count == 1 ifTrue:[
t2 := '(with %1 class)'
] ifFalse:[
t2 := '(with %1 classes)'
].
t := t , '\' , (resources string:t2 with:count printString)
].
count := subclassesRemoved size.
count ~~ 0 ifTrue:[
count == 1 ifTrue:[
t2 := '(and %1 subclass)'
] ifFalse:[
t2 := '(and %1 subclasses)'
].
t := t , '\' , (resources string:t2 with:count printString)
].
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box label:(resources at:'remove category').
box confirm ifTrue:[
"after querying user - do really remove classes in list1 and list2"
|keep idx|
keep := false.
(subclassesRemoved asOrderedCollection
, classesToRemove asOrderedCollection) do:[:aClassToRemove |
(CheckForInstancesWhenRemovingClasses not
or:[aClassToRemove hasInstances not
or:[self confirm:(aClassToRemove name , ' has instances - remove anyway ?')]]
) ifTrue:[
Smalltalk removeClass:aClassToRemove
] ifFalse:[
keep := true.
]
].
self updateClassCategoryList.
(classCategoryListView list includes:currentClassCategory) ifFalse:[
currentClassCategory := nil.
].
self classCategorySelectionChanged.
self switchToClass:nil.
"/ keep ifFalse:[
"/ idx := classCategoryListView list indexOf:currentClassCategory.
"/ currentClassCategory := nil.
"/ idx ~= 0 ifTrue:[
"/ classCategoryListView removeIndex:idx.
"/ ].
"/ ].
]
"Modified: 19.8.1996 / 23:22:35 / stefan"
"Modified: 10.9.1996 / 19:58:14 / cg"
!
classCategoryRename
"launch an enterBox to rename current class category"
|box|
self checkClassCategorySelected ifFalse:[^ self].
box := self enterBoxTitle:'rename class category to:' okText:'rename'.
box initialText:currentClassCategory.
box action:[:aString | self renameCurrentClassCategoryTo:aString].
box showAtPointer
!
classCategorySpawn
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClassCategory:currentClassCategory
]
]
!
classCategorySpawnFullClass
"create a new SystemBrowser browsing full class"
|newBrowser|
self withWaitCursorDo:[
newBrowser := SystemBrowser browseFullClasses
" "
.
currentClass notNil ifTrue:[
newBrowser switchToClassNamed:(currentClass name)
]
" "
]
!
classCategoryUpdate
"update class category list and dependants"
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
currentClass notNil ifTrue:[
oldClassName := currentClass name.
(oldClassName endsWith:'-old') ifTrue:[
oldClassName := oldClassName copyWithoutLast:4 "copyTo:(oldClassName size - 4)"
]
].
oldMethodCategory := currentMethodCategory.
classCategoryListView setContents:(self listOfAllClassCategories).
currentClassCategory notNil ifTrue:[
classCategoryListView setSelectElement:currentClassCategory.
self classCategorySelectionChanged.
oldClassName notNil ifTrue:[
classListView setSelectElement:oldClassName.
self switchToClass:(Smalltalk at:oldClassName asSymbol).
self classSelectionChanged.
oldMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory.
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
]
]
]
"Modified: 26.5.1996 / 15:03:57 / cg"
! !
!BrowserView methodsFor:'class category source administration'!
classCategoryCheckinEach
(self checkSelectionChangeAllowedWithCompare:false) ifFalse:[^ self].
self withWaitCursorDo:[
|logMessage classes|
logMessage := self getLogMessageFor:'(any in classCategory ', currentClassCategory, ')'.
logMessage notNil ifTrue:[
(currentClassCategory = '* all *'
or:[currentClassCategory = '* hierarchy *']) ifTrue:[
classes := Smalltalk allClasses
] ifFalse:[
classes := Smalltalk allClassesInCategory:currentClassCategory.
].
lastSourceLogMessage := logMessage.
classes do:[:aClass |
self busyLabel:'checking in %1' with:aClass name.
"/ ca does not want boxes to pop up all over ...
InformationSignal handle:[:ex |
Transcript showCR:ex errorString
] do:[
self classCheckin:aClass withLog:logMessage
"/ (aClass sourceCodeManager)
"/ checkinClass:aClass
"/ logMessage:logMessage.
].
self normalLabel.
]
].
self normalLabel.
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 18.5.1996 / 15:38:00 / cg"
"Modified: 15.6.1996 / 00:25:58 / stefan"
!
classCategoryRepositoryHistory
(self checkSelectionChangeAllowedWithCompare:false) ifFalse:[^ self].
self withWaitCursorDo:[
|timeGoal aStream box y component timeGoalListPop|
box := Dialog new.
(box addTextLabel:(resources string:'repository change report')) adjust:#left.
box addVerticalSpace:20.
timeGoal := 'yesterday' asValue.
y := box yPosition.
component := box addTextLabel:(resources string:'list changes since (mm/dd):').
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
timeGoalListPop := box addComboBoxOn:timeGoal tabable:true.
timeGoalListPop width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
timeGoalListPop list:#('yesterday'
'a week ago'
'a month ago'
'a year ago'
'all'
).
box addAbortButton; addOkButton.
box open.
box accepted ifTrue:[
timeGoal := timeGoal value.
"/ timeGoal := Dialog
"/ request:'list changed repository containers since (mm/dd):
"/
"/You can also specify the date as
"/''yesterday'', ''a week ago'' or ''a month ago''
"/
"/'
"/ initialAnswer:'yesterday'
"/ onCancel:nil.
"/
"/ timeGoal notNil ifTrue:[
self busyLabel:'extracting history ...' with:nil.
aStream := WriteStream on:(String new:200).
Processor activeProcess withLowerPriorityDo:[
SourceCodeManager notNil ifTrue:[
SourceCodeManager
writeHistoryLogSince:timeGoal
to:aStream.
] ifFalse:[
aStream nextPutLine:'no history available (no SourceCodeManagement installed)'
].
].
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := nil.
self normalLabel
].
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 11.9.1996 / 14:02:49 / cg"
! !
!BrowserView methodsFor:'class category stuff'!
checkClassCategorySelected
currentClassCategory isNil ifTrue:[
self warn:'select a class category first'.
^ false
].
^ true
!
classCategorySelection:lineNr
"user clicked on a class category line - show classes.
If switching to hierarchy or all, keep current selections"
|newCategory oldClass oldName classIndex|
newCategory := classCategoryListView selectionValue.
(newCategory startsWith:'*') ifTrue:[
"etiher all or hierarchy;
remember current selections and switch after showing class list"
oldClass := currentClass
].
currentClassCategory := newCategory.
oldClass isNil ifTrue:[
self classCategorySelectionChanged
] ifFalse:[
oldName := oldClass name.
self withWaitCursorDo:[
self updateClassList
].
"stupid - search for class name in (indented) list"
classIndex := classListView list findFirst:[:elem | elem endsWith:oldName].
classIndex ~~ 0 ifTrue:[
classListView setSelection:classIndex.
self switchToClass:(Smalltalk at:(oldName asSymbol))
] ifFalse:[
self normalLabel.
]
]
"Modified: 25.5.1996 / 12:25:52 / cg"
!
classCategorySelectionChanged
"class category has changed - update dependent views"
self withWaitCursorDo:[
self switchToClass:nil.
aspect := nil.
actualClass := acceptClass := nil.
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
codeView explainAction:nil.
codeView acceptAction:nil
]
"Modified: 8.2.1996 / 13:35:18 / cg"
!
listOfAllClassCategories
"return a list of all class categories"
|newList cat|
newList := Set with:'* all *' with:'* hierarchy *'.
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
cat := aClass category.
cat isNil ifTrue:[
cat := '* no category *'
].
cat ~= 'obsolete' ifTrue:[
newList add:cat
]
]
].
^ newList asOrderedCollection sort.
!
renameCurrentClassCategoryTo:aString
"helper - do the rename"
|any categories|
currentClassCategory notNil ifTrue:[
any := false.
Smalltalk allBehaviorsDo:[:aClass |
aClass category = currentClassCategory ifTrue:[
aClass category:aString.
any := true
]
].
any ifFalse:[
categories := classCategoryListView list.
categories remove:currentClassCategory.
categories add:aString.
categories sort.
classCategoryListView setContents:categories.
currentClassCategory := aString.
classCategoryListView setSelectElement:aString.
] ifTrue:[
currentClassCategory := aString.
self updateClassCategoryList.
self updateClassListWithScroll:false
]
]
"Modified: 26.5.1996 / 15:02:55 / cg"
!
switchToAnyMethod:aSelectorString
"find all implementors of aSelectorString, and present a list
to choose from. When an entry is selected, switch to that class/selector.
This allows for quickly moving around in the system."
|classes sel box theClassName|
classes := OrderedCollection new.
aSelectorString knownAsSymbol ifTrue:[
sel := aSelectorString asSymbol.
Smalltalk allClassesDo:[:aClass |
(aClass includesSelector:sel) ifTrue:[
classes add:aClass.
].
(aClass class includesSelector:sel) ifTrue:[
classes add:aClass class.
].
]
].
classes size == 0 ifTrue:[
SystemBrowser showNoneFound.
^ self
].
classes size > 1 ifTrue:[
box := ListSelectionBox title:(resources string:'#%1\in which class ?' with:aSelectorString) withCRs.
box okText:(resources string:'show').
box list:(classes collect:[:aClass | aClass name]) asSortedCollection.
box action:[:aString | theClassName := aString].
box entryCompletionBlock:[:contents |
|s l what m|
s := contents withoutSpaces.
l := classes select:[:cls | cls name startsWith:s].
l size > 0 ifTrue:[
box list:(l collect:[:aClass | aClass name]) asSortedCollection.
box contents:l first name.
l size ~~ 1 ifTrue:[
self beep
]
]
].
box showAtPointer.
] ifFalse:[
theClassName := classes first name
].
theClassName notNil ifTrue:[
self switchToClassNamed:theClassName.
self updateMethodCategoryList.
self switchToMethodNamed:aSelectorString.
].
"Modified: 1.9.1995 / 01:39:58 / claus"
"Modified: 28.5.1996 / 16:54:42 / cg"
!
updateClassCategoryList
self updateClassCategoryListWithScroll:true
!
updateClassCategoryListWithScroll:scroll
|oldClassCategory oldClass oldMethodCategory oldMethod
oldSelector newCategoryList|
classMethodListView notNil ifTrue:[ ^ self ].
oldClassCategory := currentClassCategory.
oldClass := currentClass.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
oldSelector := currentSelector
].
classCategoryListView notNil ifTrue:[
newCategoryList := self listOfAllClassCategories.
newCategoryList = classCategoryListView list ifFalse:[
scroll ifTrue:[
classCategoryListView contents:newCategoryList
] ifFalse:[
classCategoryListView setContents:newCategoryList
]
]
].
oldClassCategory notNil ifTrue:[
classCategoryListView notNil ifTrue:[
classCategoryListView setSelectElement:oldClassCategory
]
].
classListView notNil ifTrue:[
oldClass notNil ifTrue:[
classListView setSelectElement:(oldClass name)
]
].
oldMethodCategory notNil ifTrue:[
methodCategoryListView notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory
].
].
oldSelector notNil ifTrue:[
methodListView notNil ifTrue:[
methodListView setSelectElement:oldSelector
].
]
"Modified: 26.5.1996 / 15:04:25 / cg"
! !
!BrowserView methodsFor:'class list menu'!
classClassInstVars
"show class instance variables in codeView and setup accept-action
for a class-instvar-definition change"
self doClassMenu:[:currentClass |
|s|
s := WriteStream on:(String new).
currentClass fileOutClassInstVarDefinitionOn:s.
codeView contents:(s contents).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
Compiler evaluate:theCode asString notifying:codeView compile:false.
codeView modified:false.
self normalLabel.
self updateClassList.
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #classInstVars.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:34 / cg"
!
classComment
"show the classes comment in the codeView.
Also, set accept action to change the comment."
self classShowFrom:#comment
set:#comment:
aspect:#comment
default:nil
!
classDefinition
"show class definition in codeView and setup accept-action for
a class-definition change.
Extract documentation either from a documentation method or
from the comment - not a biggy, but beginners will like
it when exploring the system."
self doClassMenu:[:currentClass |
|m s aStream isComment|
aStream := WriteStream on:(String new:200).
currentClass fileOutDefinitionOn:aStream.
currentClass isLoaded ifTrue:[
"
add documentation as a comment, if there is any
"
m := currentClass class compiledMethodAt:#documentation.
m notNil ifTrue:[
s := m comment.
isComment := false.
] ifFalse:[
"try comment"
s := currentClass comment.
s notNil ifTrue:[
s isEmpty ifTrue:[
s := nil
] ifFalse:[
(s includes:$") ifTrue:[
s := s copy replaceAll:$" by:$'.
].
isComment := true
]
]
].
].
aStream cr; cr; cr; cr; cr.
s isNil ifTrue:[
aStream nextPut:$" ; cr; nextPutAll:' no comment or documentation found'; cr.
] ifFalse:[
aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
aStream cr; nextPutAll:s; cr; cr.
aStream nextPutAll:' Notice: '; cr.
aStream nextPutAll:' the above string has been extracted from the classes '.
aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
aStream cr.
aStream nextPutAll:' It will not be preserved when accepting a new class definition.'; cr.
].
aStream nextPut:$".
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
(Compiler evaluate:theCode asString notifying:codeView compile:false)
isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
]
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #definition.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:36 / cg"
!
classDocumentation
"show classes documentation (i.e. open doc-View on it)"
self doClassMenu:[:currentClass |
HTMLDocumentView
openFullOnText:(HTMLDocGenerator htmlDocOf:currentClass)
inDirectory:(Smalltalk getSystemFileName:'doc/online/english')
]
"Created: 18.5.1996 / 12:12:20 / cg"
"Modified: 20.5.1996 / 20:30:52 / cg"
!
classFileOut
"fileOut the current class.
Catch errors (sure, you like to know if it failed) and
warn if any)"
self doClassMenu:[:currentClass |
|msg|
currentClass isPrivate ifTrue:[
self warn:'You must fileOut the owning class: ' , currentClass owningClass name
] ifFalse:[
self busyLabel:'saving %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot fileOut: %1\(%2)' with:currentClass name with:ex errorString.
ex return.
] do:[
currentClass fileOut.
].
].
self normalLabel.
]
"Modified: 14.10.1996 / 20:12:24 / cg"
!
classFileOutBinary
"fileOut the current class as binary bytecode."
|mode|
mode := Dialog choose:(resources string:'save including sources ?')
labels:(resources array:#('cancel' 'discard' 'by file reference' 'include source'))
values:#(nil #discard #reference #keep)
default:#keep.
mode isNil ifTrue:[^ self]. "/ cancelled
self doClassMenu:[:currentClass |
|msg|
currentClass isPrivate ifTrue:[
self warn:'You must fileOut the owning class: ' , currentClass owningClass name
] ifFalse:[
self busyLabel:'saving binary of %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1\(%2)' with:ex parameter with:ex errorString.
ex return.
] do:[
currentClass binaryFileOutWithSourceMode:mode.
].
].
self normalLabel.
]
"Created: 24.1.1996 / 21:11:03 / cg"
"Modified: 14.10.1996 / 20:12:46 / cg"
!
classHierarchy
"show current classes hierarchy in codeView"
self doClassMenu:[:currentClass |
|aStream|
aStream := WriteStream on:(String new:200).
actualClass printHierarchyOn:aStream.
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #hierarchy.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:37 / cg"
!
classInspect
"inspect the current class"
self checkClassSelected ifFalse:[^ self].
currentClass inspect.
!
classInstancesInspect
"inspect the current classes instances"
self checkClassSelected ifFalse:[^ self].
currentClass allInstances inspect.
"Created: 24.2.1996 / 16:12:14 / cg"
!
classLoad
"load an autoloaded class"
|nm|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
Autoload autoloadFailedSignal handle:[:ex |
self warn:(resources string:'autoload of %1 failed.
Check your source directory for a file named %1.st
and/or the abbreviation file for its shortened name.') with:nm.
ex return.
] do:[
currentClass autoload.
currentClass := actualClass := nil.
self switchToClassNamed:nm
]
"Modified: 4.3.1996 / 12:16:05 / cg"
!
classMenu
"sent by classListView to ask for the menu"
|specialMenu labels selectors shorties m|
currentClass isNil ifTrue:[
labels := #(
'fileIn new from repository ...'
).
selectors := #(
classLoadNewRevision
).
] ifFalse:[
labels := #(
'fileOut binary'
'-'
'inspect class'
'inspect instances'
'-'
'primitive definitions'
'primitive variables'
'primitive functions'
'-'
'source container ...'
'remove source container ...'
'-'
'revision info'
'compare with repository ...'
'-'
'check into source repository'
'fileIn from repository ...'
).
selectors := #(
classFileOutBinary
nil
classInspect
classInstancesInspect
nil
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions
nil
classModifyContainer
classRemoveContainer
nil
classRevisionInfo
classCompareWithNewestInRepository
nil
classCheckin
classLoadRevision
).
].
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self.
currentClass notNil ifTrue:[
currentClass sourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classModifyContainer classRemoveContainer
classRevisionInfo
classLoadRevision classCheckin
classCompareWithNewestInRepository).
].
currentClass isPrivate ifTrue:[
specialMenu disableAll:#(
classFileOutBinary
classModifyContainer
classRemoveContainer
classRevisionInfo
classLoadRevision classCheckin
classCompareWithNewestInRepository
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions).
]
] ifFalse:[
SourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classLoadNewRevision)
]
].
device ctrlDown ifTrue:[
^ specialMenu
].
currentClass isNil ifTrue:[
labels := #(
'new class'
).
selectors := #(
classNewClass
).
] ifFalse:[
currentClass isLoaded ifFalse:[
labels := #(
'definition'
'documentation'
'-'
'new class'
'-'
'load'
).
selectors := #(
classDefinition
classDocumentation
nil
classNewClass
nil
classLoad
).
] ifTrue:[
fullProtocol ifTrue:[
labels := #(
'hierarchy'
'definition'
'documentation'
'comment'
'class instvars'
).
selectors := #(
classHierarchy
classDefinition
classDocumentation
classComment
classClassInstVars
).
] ifFalse:[
labels := #(
'fileOut'
'printOut'
'printOut protocol'
" 'printOut full protocol' "
'-'
'SPAWN_CLASS'
'spawn full protocol'
'spawn hierarchy'
'spawn subclasses'
'-'
).
selectors := #(
classFileOut
classPrintOut
classPrintOutProtocol
" classPrintOutFullProtocol "
nil
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
classSpawnSubclasses
nil
).
fullClass ifFalse:[
labels := labels , #(
'hierarchy'
'definition'
'documentation'
'comment'
'class instvars'
"/ 'protocols'
'-'
).
selectors := selectors , #(
classHierarchy
classDefinition
classDocumentation
classComment
classClassInstVars
"/ classProtocols
nil
).
].
labels := labels , #(
'class refs'
'-'
'new class'
'new subclass'
).
selectors := selectors , #(
classRefs
nil
classNewClass
classNewSubclass
).
PrivateMetaclass notNil ifTrue:[
labels := labels , #(
'new private class'
).
selectors := selectors , #(
classNewPrivateClass
).
].
labels := labels , #(
'rename ...'
'remove'
).
selectors := selectors , #(
classRename
classRemove
).
currentClass wasAutoloaded ifTrue:[
labels := labels , #(
'unload'
).
selectors := selectors , #(
classUnload
).
]
]
].
].
shorties := (Array new:labels size) , #(nil #'Ctrl').
labels := labels , #(
'='
'others'
).
selectors := selectors , #(
nil
otherMenu
).
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
(currentClass notNil
and:[currentClass isPrivate]) ifTrue:[
m disableAll:#(
classFileOut
)
].
m subMenuAt:#otherMenu put:specialMenu.
^ m
"Modified: 26.10.1996 / 11:37:39 / cg"
!
classNewClass
"create a class-definition prototype in codeview"
|nm cls cat|
nm := 'Object'.
currentClass notNil ifTrue:[
(cls := currentClass superclass) notNil ifTrue:[
nm := cls name
]
].
cat := currentClassCategory.
cat isNil ifTrue:[
cat := '* no category *'
].
self classClassDefinitionTemplateFor:nm in:cat private:false.
aspect := nil.
"Modified: 11.10.1996 / 16:01:32 / cg"
!
classNewPrivateClass
"create a class-definition prototype in codeview"
|nm cls cat|
nm := 'Object'.
self classClassDefinitionTemplateFor:nm in:nil private:true.
aspect := nil.
"Created: 11.10.1996 / 16:01:20 / cg"
!
classNewSubclass
"create a subclass-definition prototype in codeview"
self doClassMenu:[:currentClass |
self classClassDefinitionTemplateFor:(currentClass name)
in:(currentClass category)
private:false.
aspect := nil
]
"Modified: 11.10.1996 / 16:01:42 / cg"
!
classPrimitiveDefinitions
"show the classes primitiveDefinition in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveDefinitionsString
set:#primitiveDefinitions:
aspect:#primitiveDefinitions
default:'%{
/*
* includes, defines, structure definitions
* and typedefs come here.
*/
%}'
!
classPrimitiveFunctions
"show the classes primitiveFunctions in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveFunctionsString
set:#primitiveFunctions:
aspect:#primitiveFunctions
default:'%{
/*
* any local C (helper) functions
* come here (please, define as static)
*/
%}'
!
classPrimitiveVariables
"show the classes primitiveVariables in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveVariablesString
set:#primitiveVariables:
aspect:#primitiveVariables
default:'%{
/*
* any local C variables
* come here (please, define as static)
*/
%}'
!
classPrintOut
self classPrintOutWith:#printOutOn:
!
classPrintOutFullProtocol
self classPrintOutWith:#printOutFullProtocolOn:
!
classPrintOutProtocol
self classPrintOutWith:#printOutProtocolOn:
!
classPrintOutWith:aSelector
self doClassMenu:[:currentClass |
|printStream|
printStream := Printer new.
currentClass perform:aSelector with:printStream.
printStream close
]
!
classProtocols
^ self
!
classRefs
self doClassMenu:[:currentClass |
self withSearchCursorDo:[
SystemBrowser browseReferendsOf:currentClass name asSymbol
]
]
"Created: 23.11.1995 / 14:11:43 / cg"
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
|count t box|
currentClass notNil ifTrue:[
count := currentClass allSubclasses size.
t := 'remove %1'.
count ~~ 0 ifTrue:[
t := t , '\(with %2 subclass'.
count ~~ 1 ifTrue:[
t := t , 'es'
].
t := (t , ')')
].
t := t , ' ?'.
t := (resources string:t with:currentClass name with:count) withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box confirm ifTrue:[
"after querying user - do really remove current class
and all subclasses
"
self doClassMenu:[:currentClass |
|didRemove|
didRemove := false.
"
query ?
"
currentClass allSubclassesDo:[:aSubClass |
(CheckForInstancesWhenRemovingClasses not
or:[aSubClass hasInstances not
or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
ifTrue:[
Smalltalk removeClass:aSubClass
]
].
(CheckForInstancesWhenRemovingClasses not
or:[currentClass hasInstances not
or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
ifTrue:[
didRemove := true.
Smalltalk removeClass:currentClass.
].
self switchToClass:nil.
Smalltalk changed.
self updateClassList.
"if it was the last in its category, update class category list"
"
classListView numberOfLines == 0 ifTrue:[
self updateClassCategoryListWithScroll:false
].
"
didRemove ifTrue:[
methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
methodListView notNil ifTrue:[methodListView contents:nil].
codeView contents:nil.
codeView modified:false
]
]
]
]
!
classRename
"launch an enterBox for new name and query user"
|box|
self checkClassSelected ifFalse:[^ self].
box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
box initialText:(currentClass name).
box action:[:aString | self renameCurrentClassTo:aString].
box showAtPointer
!
classShowFrom:getSelector set:setSelector aspect:aspectSymbol default:default
"common helper for comment, primitive-stuff etc.
show the string returned from the classes getSelector-method,
Set acceptaction to change it via setSelector."
self doClassMenu:[:currentClass |
|text|
text := currentClass perform:getSelector.
text isNil ifTrue:[
text := default
].
codeView contents:text.
codeView modified:false.
codeView acceptAction:[:theCode |
Object abortSignal catch:[
lockUpdates := true.
currentClass perform:setSelector with:theCode asString.
codeView modified:false.
].
lockUpdates := false.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := aspectSymbol.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:40 / cg"
!
classSpawn
"create a new SystemBrowser browsing current class,
or if there is a selection, spawn a browser on the selected class
even a class/selector pair can be specified."
self doClassMenuWithSelection:[:cls :sel |
|browser|
cls isMeta ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := SystemBrowser browseClass:aClass.
browser instanceProtocol:false.
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
^ self
].
].
self warn:'oops, no class for this metaclass'.
^ self
].
browser := SystemBrowser browseClass:cls.
cls hasMethods ifFalse:[
browser instanceProtocol:false.
].
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
]
"
select 'Smalltalk allClassesDo:' and use spawn from the class menu
select 'Smalltalk' and use spawn from the class menu
"
!
classSpawnFullProtocol
"create a new browser, browsing current classes full protocol"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseFullClassProtocol:cls
]
!
classSpawnHierarchy
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseClassHierarchy:cls
]
!
classSpawnSubclasses
"create a new browser browsing current class's subclasses"
self doClassMenuWithSelection:[:cls :sel |
|subs|
subs := OrderedCollection new.
self classHierarchyOf:cls do:[:aClass :lvl |
subs add:(String new:lvl*2) , aClass name
].
"/ subs := cls allSubclasses.
(subs notNil and:[subs size ~~ 0]) ifTrue:[
SystemBrowser browseClasses:subs
title:('subclasses of ' , cls name)
sort:false
]
]
"Modified: 28.5.1996 / 13:54:53 / cg"
!
classUnload
"unload an autoloaded class"
|nm|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
currentClass unload.
self switchToClassNamed:nm
!
classUses
"a powerful tool, when trying to learn more about where
a class is used. This one searches all uses of a class,
and shows a list of uses - try it and like it"
self doClassMenu:[:currentClass |
self withSearchCursorDo:[
SystemBrowser browseUsesOf:currentClass
]
]
"Created: 23.11.1995 / 14:11:47 / cg"
!
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class and optional selector as arguments.
Otherwise, check if a class is selected and evaluate aBlock with the
current class."
|string words clsName cls sel isMeta|
string := codeView selection.
string notNil ifTrue:[
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m.
].
clsName isNil ifTrue:[
string := string asString withoutSeparators.
words := string asCollectionOfWords.
words notNil ifTrue:[
clsName := words first.
(clsName endsWith:' class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:6 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
sel := Parser selectorInExpression:string.
]
].
clsName notNil ifTrue:[
(cls := Smalltalk classNamed:clsName) notNil ifTrue:[
isMeta ifTrue:[
cls := cls class
].
self withWaitCursorDo:[
aBlock value:cls value:sel.
].
^ self
] ifFalse:[
self warn:'no class named: %1 - spawning current' with:clsName
]
].
].
classMethodListView notNil ifTrue:[
sel := classMethodListView selectionValue string.
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
].
self doClassMenu:[:currentClass | aBlock value:currentClass value:sel]
"Modified: 17.6.1996 / 16:51:49 / stefan"
"Modified: 22.10.1996 / 17:02:11 / cg"
! !
!BrowserView methodsFor:'class list source administration'!
classCheckin
"check a class into the source repository"
currentClass isLoaded ifFalse:[
self warn:'cannot checkin unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
self classCheckin:currentClass withLog:nil
].
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 15.4.1996 / 17:07:07 / cg"
!
classCheckin:aClass withLog:aLogMessage
"check a class into the source repository"
|logMessage info mgr|
aClass isLoaded ifFalse:[
self warn:'cannot checkin unloaded classes.'.
^ self.
].
aLogMessage isNil ifTrue:[
logMessage := self getLogMessageFor:aClass name.
logMessage isNil ifTrue:[^ self].
] ifFalse:[
logMessage := aLogMessage
].
mgr := (aClass sourceCodeManager).
info := mgr sourceInfoOfClass:aClass.
(info isNil
or:[(info at:#fileName ifAbsent:nil) isNil
or:[(info at:#module ifAbsent:nil) isNil
or:[(info at:#directory ifAbsent:nil) isNil]]]) ifTrue:[
(self classCreateSourceContainerFor:aClass) ifFalse:[^ self].
^ self.
].
lastSourceLogMessage := logMessage.
self busyLabel:'checking in %1' with:aClass name.
Processor activeProcess withLowerPriorityDo:[
(mgr checkinClass:aClass logMessage:logMessage) ifFalse:[
self warn:'checkin failed'.
].
aspect == #revisionInfo ifTrue:[
self classListUpdate
].
].
self normalLabel.
"Modified: 15.4.1996 / 17:03:19 / cg"
"Created: 15.4.1996 / 17:06:39 / cg"
"Modified: 15.6.1996 / 00:22:49 / stefan"
!
classCompareWithNewestInRepository
"open a diff-textView comparing the current (in-image) version
with the most recent version found in the repository."
currentClass isLoaded ifFalse:[
self warn:'cannot compare unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
|aStream comparedSource currentSource v rev revString thisRevString mgr
nm msg|
nm := currentClass name.
rev := currentClass binaryRevision.
mgr := currentClass sourceCodeManager.
msg := resources string:'compare to revision: (empty for newest)'.
rev notNil ifTrue:[
msg := msg , '\\(%1 is based upon rev %2)'
].
rev := Dialog request:(resources string:msg with:nm with:rev) withCRs
onCancel:nil.
rev notNil ifTrue:[
rev withoutSpaces isEmpty ifTrue:[
msg := 'extracting newest %1'.
aStream := mgr getMostRecentSourceStreamForClassNamed:nm.
revString := 'newest'
] ifFalse:[
msg := 'extracting previous %1'.
aStream := mgr getSourceStreamFor:currentClass revision:rev.
revString := rev
].
self busyLabel:msg with:nm.
aStream isNil ifTrue:[
self warn:'could not extract source from repository'.
^ self
].
comparedSource := aStream contents asString.
aStream close.
self busyLabel:'generating current source ...' with:nil.
aStream := '' writeStream.
Method flushSourceStreamCache.
currentClass fileOutOn:aStream withTimeStamp:false.
currentSource := aStream contents asString.
aStream close.
self busyLabel:'comparing ...' with:nil.
comparedSource = currentSource ifTrue:[
self information:'versions are identical'.
] ifFalse:[
thisRevString := currentClass revision.
thisRevString isNil ifTrue:[
thisRevString := 'no revision'
].
v := DiffTextView
openOn:currentSource label:'current (' , thisRevString , ')'
and:comparedSource label:'repository (' , revString , ')'.
v label:'comparing ' , nm.
].
self normalLabel.
]
]
"Created: 14.11.1995 / 16:43:15 / cg"
"Modified: 12.10.1996 / 17:22:35 / cg"
!
classCreateSourceContainerFor:aClass
"let user specify the source-repository values for aClass"
^ self
classDefineSourceContainerFor:aClass
title:(resources string:'Repository information for %1' with:aClass name)
text:(resources string:'CREATE_REPOSITORY' with:aClass name)
createDirectories:true
createContainer:true.
"Modified: 15.4.1996 / 17:07:57 / cg"
!
classDefineSourceContainerFor:aClass title:title text:boxText createDirectories:createDirs createContainer:createContainer
"let user specify the source-repository values for aClass"
|box className
moduleHolder packageHolder fileNameHolder
oldModule oldPackage oldFileName
module package fileName
y component info project nm mgr creatingNew|
aClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ false.
].
className := aClass name.
"/
"/ defaults, if nothing at all is known
"/
(module := lastModule) isNil ifTrue:[
module := (OperatingSystem getLoginName).
].
(package := lastPackage) isNil ifTrue:[
package := 'private'.
].
"/
"/ try to extract some useful defaults from the current project
"/
(Project notNil and:[(project := Project current) notNil]) ifTrue:[
package isNil ifTrue:[
(nm := project repositoryDirectory) isNil ifTrue:[
nm := project name
].
package := nm.
].
module isNil ifTrue:[
(nm := project repositoryModule) notNil ifTrue:[
module := nm
]
].
].
"/
"/ ask the sourceCodeManager if it knows anything about that class
"/ if so, take that as a default.
"/
info := (mgr := aClass sourceCodeManager) sourceInfoOfClass:aClass.
info notNil ifTrue:[
(info includesKey:#module) ifTrue:[
module := (info at:#module).
].
(info includesKey:#directory) ifTrue:[
package := (info at:#directory).
].
fileName := mgr containerFromSourceInfo:info.
"/ (info includesKey:#fileName) ifTrue:[
"/ fileName := (info at:#fileName).
"/ ] ifFalse:[
"/ (info includesKey:#expectedFileName) ifTrue:[
"/ fileName := (info at:#expectedFileName).
"/ ] ifFalse:[
"/ (info includesKey:#classFileNameBase) ifTrue:[
"/ fileName := (info at:#classFileNameBase) , '.st'.
"/ ]
"/ ]
"/ ]
].
fileName isNil ifTrue:[
fileName := (Smalltalk fileNameForClass:aClass) , '.st'.
].
fileNameHolder := fileName asValue.
moduleHolder := module asValue.
packageHolder := package asValue.
"/
"/ should check for conflicts (i.e. if such a container already exists) ...
"/
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifTrue:[
"/ for now - this needs more work.
"/ self information:(resources
"/ string:'%1 is already contained in the container:
"/
"/ %2 / %3 / %4'
"/ with:className
"/ with:module
"/ with:package
"/ with:fileName).
"/ ^ false.
"/
(Dialog confirm:(resources
string:'Notice: there already is a container for %1 in:
%2 / %3 / %4
To change it, press continue.'
with:className
with:module
with:package
with:fileName)
yesLabel:(resources string:'continue')
noLabel:(resources string:'cancel'))
ifFalse:[
^ false
].
oldModule := module.
oldPackage := package.
oldFileName := fileName
].
"/
"/ open a dialog for this
"/
box := DialogBox new.
box label:title.
component := box addTextLabel:boxText withCRs.
component adjust:#left; borderWidth:0.
box addVerticalSpace.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:(resources string:'Module:').
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:moduleHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Package:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:packageHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Filename:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:fileNameHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
component := box addTextLabel:'Notice: class seems to have no container yet.'.
component adjust:#left; borderWidth:0.
creatingNew := true.
] ifTrue:[
creatingNew := false.
].
box addVerticalSpace.
box addAbortButton; addOkButton.
box showAtPointer.
box accepted ifTrue:[
module := moduleHolder value withoutSpaces.
package := packageHolder value withoutSpaces.
fileName := fileNameHolder value withoutSpaces.
(fileName endsWith:',v') ifTrue:[
fileName := fileName copyWithoutLast:2
].
(fileName endsWith:'.st') ifFalse:[
fileName := fileName , '.st'
].
info := aClass revisionInfo.
info notNil ifTrue:[
(info includesKey:#repositoryPathName) ifFalse:[
info := nil
]
].
info isNil ifTrue:[
creatingNew ifFalse:[
(self confirm:(resources string:'The repository already contains a container named "%3" in "%1/%2" !!\\Checkin %4 anyway ? (DANGER - be careful)'
withArgs:(Array with:module with:package with:fileName with:className)) withCRs)
ifFalse:[
^ false
].
].
(self confirm:(resources string:'%1 does not have any (usable) revision info (#version method)\\Shall I create one ?' with:className) withCRs)
ifFalse:[
^ false
].
aClass updateVersionMethodFor:(mgr initialRevisionStringFor:aClass
inModule:module
package:package
container:fileName).
].
"/
"/ check for the module
"/
(mgr checkForExistingModule:module) ifFalse:[
(createDirs or:[creatingNew]) ifFalse:[
self warn:(resources string:'a module named %1 does not exist in the source code management' with:module).
^ false
].
(self confirm:(resources string:'%1 is a new module.\\create it ?' with:module) withCRs) ifFalse:[
^ false.
].
(mgr createModule:module) ifFalse:[
self warn:(resources string:'cannot create new module: %1' with:module).
^ false.
]
].
lastModule := module.
"/
"/ check for the package
"/
(mgr checkForExistingModule:module package:package) ifFalse:[
(createDirs or:[creatingNew]) ifFalse:[
self warn:(resources string:'a package named %1 does not exist module %2' with:module with:package).
^ false
].
(self confirm:(resources string:'%1 is a new package (in module %2).\\create it ?' with:package with:module) withCRs) ifFalse:[
^ false.
].
(mgr createModule:module package:package) ifFalse:[
self warn:(resources string:'cannot create new package: %1 (in module %2)' with:package with:module).
^ false.
]
].
lastPackage := package.
"/
"/ check for the container itself
"/
(mgr checkForExistingContainerInModule:module package:package container:fileName) ifTrue:[
creatingNew ifTrue:[
self warn:(resources string:'container for %1 already exists in %2/%3.' with:fileName with:module with:package) withCRs.
].
"/ (oldModule notNil
"/ and:[(oldModule ~= module)
"/ or:[oldPackage ~= package
"/ or:[oldFileName ~= fileName]]])
"/ ifFalse:[
"/ self warn:(resources string:'no change').
"/ ^ false.
"/ ].
(self confirm:(resources string:'check %1 into the existing container
%2 / %3 / %4 ?'
with:className
with:module
with:package
with:fileName) withCRs)
ifFalse:[
^ false.
].
aClass updateVersionMethodFor:'changed container'.
(mgr
checkinClass:aClass
fileName:fileName
directory:package
module:module
logMessage:('changed source container from ' , oldFileName))
ifFalse:[
(self confirm:'no easy merge seems possible; force checkin (no merge) ?') ifFalse:[
self normalLabel.
^ false.
].
(mgr
checkinClass:aClass
fileName:fileName
directory:package
module:module
logMessage:('changed source container from ' , oldFileName)
force:true)
ifFalse:[
self warn:(resources string:'failed to check into existing container.').
self normalLabel.
^ false.
].
].
self normalLabel.
^ true
] ifFalse:[
(createContainer or:[creatingNew]) ifFalse:[
(self confirm:(resources string:'no container exists for %1 in %2/%3\\create ?'
with:fileName with:module with:package) withCRs) ifFalse:[
^ false
]
]
].
(mgr
createContainerFor:aClass
inModule:module
package:package
container:fileName) ifFalse:[
self warn:(resources string:'failed to create container.').
self normalLabel.
^ false.
].
self normalLabel.
^ true
].
box destroy.
^ false
"Modified: 11.9.1996 / 18:36:18 / cg"
!
classLoadNewRevision
"let user specify a container and fileIn from there"
|box
moduleHolder packageHolder fileNameHolder
module package fileName aStream
y component mgr|
mgr := SourceCodeManager.
mgr isNil ifTrue:[^ false].
fileNameHolder := '' asValue.
moduleHolder := (OperatingSystem getLoginName) asValue.
packageHolder := 'private' asValue.
"/
"/ open a dialog for the module/package/container
"/
box := DialogBox new.
box label:'container fileIn'.
component := box addTextLabel:(resources string:'container to fileIn') withCRs.
component adjust:#left; borderWidth:0.
box addVerticalSpace.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:(resources string:'Module:').
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:moduleHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Package:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:packageHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Filename:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:fileNameHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
box addAbortButton; addOkButton.
box showAtPointer.
box destroy.
box accepted ifFalse:[
^ false
].
module := moduleHolder value withoutSpaces.
package := packageHolder value withoutSpaces.
fileName := fileNameHolder value withoutSpaces.
(fileName endsWith:',v') ifTrue:[
fileName := fileName copyWithoutLast:2
].
(fileName endsWith:'.st') ifFalse:[
fileName := fileName , '.st'
].
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
self warn:'no such container'.
^ false
].
aStream := mgr
streamForClass:nil
fileName:fileName
revision:#newest
directory:package
module:module
cache:false.
aStream isNil ifTrue:[
self warn:'could not fileIn from repository'.
^ false.
].
self busyLabel:'loading from %1' with:(module , '/' , package , '/' , fileName).
Class withoutUpdatingChangesDo:[
[
aStream fileIn.
] valueNowOrOnUnwindDo:[
aStream close.
self normalLabel.
Smalltalk changed.
].
].
^ false
"Created: 13.9.1996 / 09:27:09 / cg"
"Modified: 13.9.1996 / 09:34:25 / cg"
!
classLoadRevision
"load a specific revision into the system - especially useful to
upgrade a class to the newest revision"
currentClass isLoaded ifFalse:[
self warn:'cannot load specific releases of autoloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
|aStream comparedSource currentSource v rev revString what mgr keep className
newClass prevCategory ok|
rev := Dialog request:'load which revision: (empty for newest)' onCancel:nil.
rev notNil ifTrue:[
className := currentClass name.
(className includesString:'_rev_') ifTrue:[
self warn:'select the original class and try again.'.
^ self
].
mgr := currentClass sourceCodeManager.
ok := false.
rev withoutSpaces isEmpty ifTrue:[
what := className , '(newest)'.
self busyLabel:'extracting %1' with:what.
aStream := mgr getMostRecentSourceStreamForClassNamed:className.
revString := 'newest'.
keep := false.
] ifFalse:[
what := className , '(' , rev , ')'.
self busyLabel:'extracting %1' with:what.
aStream := mgr getSourceStreamFor:currentClass revision:rev.
revString := rev.
keep := true.
].
aStream isNil ifTrue:[
self warn:'cannot find classes source.'.
^ self.
].
self busyLabel:'loading %1' with:what .
[
Class withoutUpdatingChangesDo:[
"/ rename the current class - for backup
prevCategory := currentClass category.
currentClass category:'* obsolete *'.
Smalltalk renameClass:currentClass to:className , '_saved'.
aStream fileIn.
"/ did that work ?
newClass := Smalltalk at:className ifAbsent:nil.
newClass isNil ifTrue:[
self warn:'fileIn failed - undoing changes ...'.
Smalltalk renameClass:currentClass to:className.
currentClass category:prevCategory.
] ifFalse:[
"/
"/ if we loaded an old version, rename that one and fix the name of the
"/ current class
"/
keep ifTrue:[
Smalltalk renameClass:newClass to:(className , '_rev_' , rev).
newClass category:'* old versions *'.
Smalltalk renameClass:currentClass to:className.
currentClass category:prevCategory.
].
ok := true.
]
].
] valueNowOrOnUnwindDo:[
aStream close.
self normalLabel.
Smalltalk changed.
].
ok ifTrue:[
self switchToClassNamed:newClass name.
]
]
]
"Created: 14.11.1995 / 16:43:15 / cg"
"Modified: 12.10.1996 / 17:22:40 / cg"
!
classModifyContainer
"check a class into the source repository"
currentClass isLoaded ifFalse:[
self warn:'dont know anything about unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
self
classDefineSourceContainerFor:currentClass
title:(resources string:'Repository information for %1' with:currentClass name)
text:'defining/changing the source code container'
createDirectories:true createContainer:true.
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 6.2.1996 / 16:58:58 / cg"
!
classRemoveContainer
"remove a container from the source repository"
currentClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ self.
].
self doClassMenu:[:currentClass |
self
classRemoveSourceContainerFor:currentClass
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 11.9.1996 / 12:55:42 / cg"
!
classRemoveSourceContainerFor:aClass
"show container & let user confirm twice."
|module package fileName info mgr|
aClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ false.
].
"/
"/ ask the sourceCodeManager if it knows anything about that class
"/ if so, take that as a default.
"/
mgr := aClass sourceCodeManager.
mgr isNil ifTrue:[
self warn:'No sourceCodeManagement.'.
^ false
].
info := mgr sourceInfoOfClass:aClass.
info notNil ifTrue:[
(info includesKey:#module) ifTrue:[
module := (info at:#module).
].
(info includesKey:#directory) ifTrue:[
package := (info at:#directory).
].
fileName := mgr containerFromSourceInfo:info.
].
module isNil ifTrue:[
self warn:'classes module is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
package isNil ifTrue:[
self warn:'classes package is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
fileName isNil ifTrue:[
self warn:'classes container fileName is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
self warn:'Class has no source container.' withCRs.
^ false.
].
(Dialog
choose:(resources
string:'Please confirm removal of the container for %1:
container: %2 / %3 / %4
Really remove ?'
with:aClass name
with:module
with:package
with:fileName)
labels:(Array
with:(resources string:'no')
with:(resources string:'remove'))
values:#(false true)
default:false) ifFalse:[
^ self.
].
(mgr removeContainerFor:aClass
inModule:module
package:package
container:fileName) ifFalse:[
self warn:(resources string:'failed to remove container.').
self normalLabel.
^ true.
].
^ false
"Created: 11.9.1996 / 13:06:14 / cg"
"Modified: 13.9.1996 / 19:06:06 / cg"
!
classRevisionInfo
"show current classes revision info in codeView"
self doClassMenu:[:currentClass |
|aStream info info2 s rv mgr|
aStream := WriteStream on:(String new:200).
currentClass notNil ifTrue:[
Processor activeProcess withLowerPriorityDo:[
self busyLabel:'extracting revision info' with:nil.
info := currentClass revisionInfo.
rv := currentClass binaryRevision.
rv notNil ifTrue:[
aStream nextPutAll:'**** Loaded classes binary information ****'; cr; cr.
aStream nextPutAll:' Binary based upon : ' , rv; cr.
aStream cr.
].
info notNil ifTrue:[
(info includesKey:#revision) ifFalse:[
aStream nextPutAll:'WARNING:'; cr; cr.
aStream nextPutAll:' The class seems not to be loaded from the repository.'; cr.
aStream nextPutAll:' Check carefully before checking anything in.'; cr.
aStream nextPutAll:' (i.e. compare with repository for renamed class(es), same-name but unrelated etc.)'; cr.
aStream cr.
].
aStream nextPutAll:'**** Classes source information ****'; cr; cr.
s := info at:#repositoryPath ifAbsent:nil.
s notNil ifTrue:[
aStream nextPut:' Source repository : ' , s; cr
].
aStream nextPutAll:' Filename ........ : ' , (info at:#fileName ifAbsent:'?'); cr.
aStream nextPutAll:' Revision ........ : ' , (info at:#revision ifAbsent:'?'); cr.
aStream nextPutAll:' Checkin date .... : ' , (info at:#date ifAbsent:'?') , ' ' , (info at:#time ifAbsent:'?'); cr.
aStream nextPutAll:' Checkin user .... : ' , (info at:#user ifAbsent:'?'); cr.
(info2 := currentClass packageSourceCodeInfo) notNil ifTrue:[
aStream nextPutAll:' Repository: ..... : ' , (info2 at:#module ifAbsent:'?'); cr.
aStream nextPutAll:' Directory: ...... : ' , (info2 at:#directory ifAbsent:'?'); cr.
].
aStream nextPutAll:' Container ....... : ' , (info at:#repositoryPathName ifAbsent:'?'); cr.
aStream cr.
(mgr := currentClass sourceCodeManager) notNil ifTrue:[
aStream nextPutAll:'**** Repository information ****'; cr; cr.
mgr writeRevisionLogOf:currentClass to:aStream.
]
] ifFalse:[
aStream nextPutAll:'No revision info found'; cr.
currentClass isLoaded ifFalse:[
aStream cr; nextPutAll:'This is an autoloaded class - you may see more after its loaded.'
]
]
]
].
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #revisionInfo.
self normalLabel
]
"Created: 14.11.1995 / 16:43:15 / cg"
"Modified: 25.5.1996 / 13:02:38 / cg"
!
getLogMessageFor:aString
"get a log message for when checking in a class.
Return the message or nil if aborted."
|dialog textView|
dialog := Dialog new.
(dialog addTextLabel:'enter log message for: ', aString) adjust:#left.
textView := dialog addTextBoxOn:nil
class:EditTextView
withNumberOfLines:10
hScrollable:true
vScrollable:true.
dialog width:(textView preferredExtentForLines:10 cols:70) x.
textView contents:lastSourceLogMessage.
dialog addAbortButton; addOkButton.
dialog open.
dialog accepted ifTrue:[
^ textView contents
].
^ nil
"Created: 15.6.1996 / 00:20:46 / stefan"
! !
!BrowserView methodsFor:'class stuff'!
checkClassSelected
"warn and return false, if no class is selected"
currentClass isNil ifTrue:[
self warn:'select a class first'.
^ false
].
^ true
!
classClassDefinitionTemplateFor:name in:cat private:isPrivate
"common helper for newClass and newSubclass
- show a template to define class name in category cat.
Also, set acceptaction to install the class."
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
classListView setSelection:nil.
fullClass ifFalse:[
methodCategoryListView contents:nil.
methodListView contents:nil
].
codeView contents:(self classTemplateFor:name in:cat private:isPrivate).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
|cls|
Object errorSignal handle:[:ex |
codeView error:ex errorString
position:1 to:nil from:nil.
] do:[
cls := (Compiler evaluate:theCode asString notifying:codeView compile:false).
cls isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
self switchToClassNamed:(cls name).
]
]
].
codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
"Created: 11.10.1996 / 16:01:54 / cg"
"Modified: 11.10.1996 / 16:11:22 / cg"
!
classListUpdate
RememberAspect ifTrue:[
aspect == #hierarchy ifTrue:[
^ self classHierarchy
].
aspect == #classInstVars ifTrue:[
^ self classClassInstVars
].
aspect == #comment ifTrue:[
^ self classComment
].
aspect == #primitiveDefinitions ifTrue:[
^ self classPrimitiveDefinitions
].
aspect == #primitiveFunctions ifTrue:[
^ self classPrimitiveFunctions
].
aspect == #primitiveVariables ifTrue:[
^ self classPrimitiveVariables
].
aspect == #revisionInfo ifTrue:[
^ self classRevisionInfo
].
].
self classDefinition
"Created: 23.11.1995 / 11:28:58 / cg"
"Modified: 23.11.1995 / 11:36:08 / cg"
!
classSelection:lineNr
"user clicked on a class line - show method categories"
|cls oldSelector|
(currentClassHierarchy notNil
and:[fullProtocol]) ifTrue:[
oldSelector := currentSelector.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
fullProtocol ifFalse:[
self updateVariableList.
].
oldSelector notNil ifTrue:[
self switchToMethod:oldSelector.
currentMethod notNil ifTrue:[
self switchToMethodCategory:(currentMethod category).
]
].
^ self
].
cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
cls notNil ifTrue:[
self switchToClass:cls.
self classSelectionChanged
]
"Modified: 4.6.1996 / 23:05:20 / cg"
!
classSelectionChanged
|oldMethodCategory oldMethod oldSelector|
self withWaitCursorDo:[
aspect := #definition.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldSelector := currentSelector.
showInstance ifTrue:[
actualClass := acceptClass := currentClass
] ifFalse:[
actualClass := acceptClass := currentClass class
].
currentMethodCategory := nil.
currentMethod := nil.
currentSelector := nil.
self updateMethodCategoryList.
oldMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory.
methodCategoryListView hasSelection ifTrue:[
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
].
self updateMethodList.
self updateCodeView.
self updateVariableList.
fullClass ifTrue:[
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
self compileCode:theCode asString.
codeView modified:false.
].
codeView cursor:Cursor normal.
].
] ifFalse:[
"/ self classDefinition.
self classListUpdate.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
(Compiler evaluate:theCode asString notifying:codeView compile:false)
isBehavior ifTrue:[
self classCategoryUpdate.
self updateClassListWithScroll:false.
codeView modified:false.
].
].
codeView cursor:Cursor normal.
].
].
codeView explainAction:nil.
classCategoryListView notNil ifTrue:[
(currentClassCategory = currentClass category) ifFalse:[
currentClassCategory := currentClass category.
classCategoryListView setSelectElement:currentClassCategory
]
].
self setDoitActionForClass
]
"Created: 23.11.1995 / 11:32:03 / cg"
"Modified: 26.5.1996 / 17:05:46 / cg"
!
classTemplateFor:className in:cat private:isPrivate
"return a class definition template - be smart in what is offered initially"
|aString name i|
name := 'NewClass'.
i := 1.
[name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
i := i + 1.
name := 'NewClass' , i printString
].
isPrivate ifTrue:[
aString := className , ' subclass:#' , name , '
' , ' instanceVariableNames: ''''
' , ' classVariableNames: ''''
' , ' poolDictionaries: ''''
' , ' privateIn:' , currentClass name printString
] ifFalse:[
aString := className , ' subclass:#' , name , '
' , ' instanceVariableNames: ''''
' , ' classVariableNames: ''''
' , ' poolDictionaries: ''''
' , ' category: '''.
cat notNil ifTrue:[
aString := aString , cat
].
aString := aString , ''''
].
aString := aString , '
"
Replace ''' , className , ''', ''', name , ''' and
the empty string arguments by true values.
Install (or change) the class by ''accepting'',
either via the menu or the keyboard (usually CMD-A).
To be nice to others (and yourself later), do not forget to
add some documentation; preferably under the classes documentation
protocol.
(see the ``create documentation stubs'' item in the methodList menu.)
"
'.
^ aString
"Created: 8.2.1996 / 18:22:34 / cg"
"Modified: 11.10.1996 / 16:28:42 / cg"
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
self checkClassSelected ifTrue:[
self withWaitCursorDo:[aBlock value:currentClass]
]
!
listOfAllClassesInCategory:aCategory
"return a list of all classes in a given category"
|newList classes searchCategory nm owner|
(aCategory = '* hierarchy *') ifTrue:[
newList := OrderedCollection new.
classes := Set new.
self classHierarchyOf:Object do:[:aClass :lvl|
nm := aClass name.
(classes includes:nm) ifFalse:[
classes add:nm.
newList add:(String new:lvl) , nm
]
].
^ newList
].
newList := Set new.
(aCategory = '* all *') ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
newList add:aClass name
]
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
Smalltalk allBehaviorsDo:[:aClass |
|thisCategory|
aClass isMeta ifFalse:[
thisCategory := aClass category.
((thisCategory = searchCategory)
or:[thisCategory = aCategory]) ifTrue:[
newList add:aClass name
]
]
]
].
(newList size == 0) ifTrue:[^ nil].
newList := newList asOrderedCollection sort.
"/ indent after sorting
newList := newList collect:[:item |
(item includes:$:) ifTrue:[
' ' , item
] ifFalse:[
item
]
].
^ newList
"Modified: 14.10.1996 / 18:38:26 / cg"
!
listOfClassHierarchyOf:aClass
"return a hierarchy class-list"
|startClass classes thisOne|
showInstance ifTrue:[
startClass := aClass
] ifFalse:[
startClass := aClass class.
].
classes := startClass allSuperclasses.
thisOne := Array with:startClass.
classes notNil ifTrue:[
classes := classes reverse , thisOne.
] ifFalse:[
classes := thisOne
].
fullProtocol ifFalse:[
classes := classes , startClass allSubclassesInOrder
].
^ classes collect:[:c | c name]
!
renameCurrentClassTo:aString
"helper - do the rename"
self doClassMenu:[:currentClass |
|oldName oldSym newSym cls|
(cls := Smalltalk classNamed:aString) notNil ifTrue:[
(self confirm:(resources string:'WARN_RENAME' with:aString with:cls category) withCRs)
ifFalse:[^ self]
].
oldName := currentClass name.
oldSym := oldName asSymbol.
"
currentClass setName:aString.
newSym := aString asSymbol.
Smalltalk at:oldSym put:nil.
Smalltalk removeKey:oldSym.
Smalltalk at:newSym put:currentClass.
"
"
currentClass renameTo:aString.
"
Smalltalk renameClass:currentClass to:aString.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self withWaitCursorDo:[
Transcript showCR:('searching for users of ' , oldSym); endEntry.
SystemBrowser browseReferendsOf:oldSym warnIfNone:false
]
]
"Created: 25.11.1995 / 13:02:53 / cg"
"Modified: 18.5.1996 / 15:41:27 / cg"
!
switchToClass:newClass
"switch to some other class;
keep instance protocol as it was ..."
|cls meta|
"/ fullProtocol ifTrue:[^ self].
self releaseClass.
cls := newClass.
cls isMeta ifTrue:[
meta := cls.
cls := meta soleInstance
] ifFalse:[
meta := cls class
].
currentClass := cls.
showInstance ifTrue:[
actualClass := acceptClass := cls.
] ifFalse:[
actualClass := acceptClass := meta.
].
currentClass notNil ifTrue:[
cls addDependent:self.
meta addDependent:self.
].
self normalLabel.
"Modified: 1.9.1995 / 01:04:05 / claus"
"Modified: 13.12.1995 / 15:32:49 / cg"
!
switchToClassNameMatching:aMatchString
|classNames thisName box|
classNames := Set new.
Smalltalk allBehaviorsDo:[:aClass |
thisName := aClass name.
(aMatchString match:thisName) ifTrue:[
classNames add:thisName
]
].
(classNames size == 0) ifTrue:[^ nil].
(classNames size == 1) ifTrue:[
^ self switchToClassNamed:(classNames first)
].
classNames := classNames asArray sort.
box := self listBoxTitle:'select class to switch to:'
okText:'ok'
list:classNames.
box action:[:aString | self switchToClassNamed:aString].
box showAtPointer
"Modified: 4.6.1996 / 11:34:22 / cg"
!
switchToClassNamed:aString
|meta str classSymbol theClass newCat element idx|
meta := false.
str := aString.
classSymbol := aString withoutSpaces asSymbolIfInterned.
classSymbol isNil ifTrue:[
(aString endsWith:' class') ifTrue:[
str := aString copyWithoutLast:6.
classSymbol := str asSymbolIfInterned.
classSymbol isNil ifTrue:[
^ self
].
meta := true
].
].
theClass := Smalltalk at:classSymbol.
(theClass isNil and:[str endsWith:' class']) ifTrue:[
str := str copyWithoutLast:6.
classSymbol := str asSymbolIfInterned.
classSymbol isNil ifTrue:[
^ self
].
meta := true.
theClass := Smalltalk at:classSymbol.
].
classCategoryListView notNil ifTrue:[
classCategoryListView list size == 0 ifTrue:[
classCategoryListView list:(self listOfAllClassCategories).
]
].
theClass == currentClass ifTrue:[^ self].
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
((newCat := theClass category) ~= currentClassCategory) ifTrue:[
currentClassCategory := newCat.
newCat isNil ifTrue:[
element := '* no category *'
] ifFalse:[
element := newCat.
].
classCategoryListView setSelectElement:element.
"/ classCategoryListView makeSelectionVisible.
]
]
].
self updateClassList.
self switchToClass:theClass.
idx := classListView list findFirst:[:line | line withoutSpaces = str].
classListView selection:idx.
"/ classListView setSelectElement:str.
self instanceProtocol:meta not.
self classSelectionChanged.
classCategoryListView notNil ifTrue:[
classCategoryListView setSelectElement:theClass category
]
]
"Modified: 1.9.1995 / 01:41:35 / claus"
"Modified: 17.6.1996 / 16:54:55 / stefan"
"Modified: 14.10.1996 / 20:21:23 / cg"
!
updateClassList
self updateClassListWithScroll:true
!
updateClassListWithScroll:scroll
|classes oldClassName|
classListView notNil ifTrue:[
"
refetch in case we are not up to date
"
(currentClass notNil and:[fullProtocol not]) ifTrue:[
oldClassName := currentClass name.
currentClass := Smalltalk at:(oldClassName asSymbol).
].
currentClassCategory notNil ifTrue:[
classes := self listOfAllClassesInCategory:currentClassCategory
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
classes := self listOfClassHierarchyOf:currentClassHierarchy
]
].
classListView list = classes ifFalse:[
scroll ifTrue:[
classListView contents:classes
] ifFalse:[
classListView setContents:classes
].
oldClassName notNil ifTrue:[
classListView setContents:classes.
classListView setSelectElement:oldClassName
] ifFalse:[
variableListView notNil ifTrue:[variableListView contents:nil]
]
].
scroll ifTrue:[
fullProtocol ifTrue:[
classListView scrollToBottom
]
]
]
"Modified: 26.5.1996 / 15:03:11 / cg"
! !
!BrowserView methodsFor:'class-method list menu'!
classMethodBrowse
SystemBrowser openInClass:actualClass selector:currentSelector
"Created: 13.12.1995 / 15:05:12 / cg"
"Modified: 13.12.1995 / 15:06:26 / cg"
!
classMethodFileOutAll
"fileout all methods into one source file"
|list classString selectorString cls mth outStream fileName append
fileBox|
append := false.
fileBox := FileSaveBox
title:(resources string:'save methods in:')
okText:(resources string:'save')
abortText:(resources string:'cancel')
action:[:fName | fileName := fName].
fileBox appendAction:[:fName | fileName := fName. append := true].
fileBox initialText:'some_methods.st'.
Project notNil ifTrue:[
fileBox directory:Project currentProjectDirectory
].
fileBox showAtPointer.
fileName notNil ifTrue:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
append ifTrue:[
outStream := FileStream appendingOldFileNamed:fileName
] ifFalse:[
outStream := FileStream newFileNamed:fileName.
].
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
list := classMethodListView list.
list do:[:line |
self busyLabel:'writing: ' with:line.
classString := self classFromClassMethodString:line.
selectorString := self selectorFromClassMethodString:line.
cls := Smalltalk classNamed:classString.
"/ ((classString ~= 'Metaclass') and:[classString endsWith:' class']) ifTrue:[
"/ classString := classString copyWithoutLast:6 "copyTo:(classString size - 5)".
"/ cls := (Smalltalk at:classString asSymbol).
"/ cls := cls class
"/ ] ifFalse:[
"/ cls := (Smalltalk at:classString asSymbol).
"/ ].
cls isNil ifTrue:[
self warn:'oops class %1 is gone' with:classString
] ifFalse:[
mth := cls compiledMethodAt:(selectorString asSymbol).
Class fileOutErrorSignal handle:[:ex |
|box|
box := YesNoBox
title:('fileOut error: '
, ex errorString
, '\\continue anyway ?') withCRs
yesText:'continue'
noText:'abort'.
box confirm ifTrue:[
ex proceed
].
self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
]
]
].
outStream close.
self normalLabel.
]
]
"Modified: 17.6.1996 / 16:51:11 / stefan"
"Modified: 21.6.1996 / 15:25:53 / cg"
!
classMethodMenu
<resource: #keyboard ( #Cmds #Cmdi #Cmdg ) >
|labels selectors shorties|
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'browse'
'spawn'
'spawn class'
'spawn full protocol'
'spawn hierarchy'
'-'
'senders ...'
'implementors ...'
'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
'-'
'remove'
).
shorties := #(
nil
nil
nil
nil
nil
nil
nil
nil
nil
nil
#Cmds
#Cmdi
#Cmdg
"/ nil
"/ nil
"/ nil
"/ nil
nil
nil
).
selectors := #(
methodFileOut
classMethodFileOutAll
methodPrintOut
nil
classMethodBrowse
methodSpawn
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
nil
methodSenders
methodImplementors
methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
nil
methodRemove
).
^ PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties
"Modified: 10.7.1996 / 12:46:07 / cg"
! !
!BrowserView methodsFor:'class-method stuff'!
classFromClassMethodString:aString
"helper for classMethod-list - extract class name from the string"
|pos s|
(aString endsWith:')') ifTrue:[
s := aString copyTo:(aString lastIndexOf:$()-1.
s := s withoutSpaces.
] ifFalse:[
s := aString
].
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
pos := s lastIndexOf:(Character space).
^ s copyTo:(pos - 1)
"Modified: 17.6.1996 / 17:06:59 / stefan"
"Modified: 17.7.1996 / 20:42:06 / cg"
!
classMethodSelection:lineNr
"user clicked on a class/method line - show code"
|cls string classString selectorString meta|
string := classMethodListView selectionValue string.
classString := self classFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
((classString ~= 'Metaclass') and:[classString endsWith:' class']) ifTrue:[
classString := classString copyWithoutLast:6 "copyTo:(classString size - 5)".
meta := true.
] ifFalse:[
meta := false.
].
self switchToClass:(Smalltalk at:classString asSymbol).
meta ifTrue:[cls := currentClass class] ifFalse:[cls := currentClass].
actualClass := acceptClass := cls.
currentClass isNil ifTrue:[
self warn:'oops class is gone'
] ifFalse:[
currentClassCategory := currentClass category.
currentSelector := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:currentSelector.
currentMethod isNil ifTrue:[
self warn:'oops method is gone'
] ifFalse:[
currentMethodCategory := currentMethod category.
].
self methodSelectionChanged
].
self setDoitActionForClass
"Modified: 31.8.1995 / 11:56:02 / claus"
"Modified: 17.6.1996 / 16:51:28 / stefan"
"Modified: 15.7.1996 / 11:44:38 / cg"
!
selectorFromClassMethodString:aString
"helper for classMethod-list - extract selector from the string"
|pos s|
(aString endsWith:')') ifTrue:[
s := aString copyTo:(aString lastIndexOf:$()-1.
s := s withoutSpaces.
] ifFalse:[
s := aString
].
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
pos := s lastIndexOf:(Character space).
^ s copyFrom:(pos + 1)
"Modified: 17.6.1996 / 17:04:38 / stefan"
"Modified: 17.7.1996 / 20:43:20 / cg"
! !
!BrowserView methodsFor:'event handling'!
handlesKeyPress:key inView:view
"this method is reached via delegation: are we prepared to handle
a keyPress in some other view ?"
<resource: #keyboard (#Find #Cmdi #Cmds #Cmdg #Cmdt #Cmda)>
|untranslatedKey|
view == classCategoryListView ifTrue:[
(key == #Find) ifTrue:[^ true].
].
((view == methodListView)
or:[view == classMethodListView]) ifTrue:[
untranslatedKey := device keyboardMap keyAtValue:key ifAbsent:key.
(untranslatedKey == #Cmdi) ifTrue:[^ true].
(untranslatedKey == #Cmds) ifTrue:[^ true].
(untranslatedKey == #Cmdg) ifTrue:[^ true].
(untranslatedKey == #Cmdt) ifTrue:[^ true].
(untranslatedKey == #Cmda) ifTrue:[^ true].
].
^ false
"Created: 2.3.1996 / 14:33:30 / cg"
"Modified: 10.7.1996 / 12:47:54 / cg"
!
keyPress:key x:x y:y view:view
"this method is reached via delegation from the classCategoryListView"
<resource: #keyboard (#Find #Cmdi #Cmds #Cmdg #Cmdt #Cmda)>
|untranslatedKey|
view == classCategoryListView ifTrue:[
(key == #Find) ifTrue:[^ self classCategoryFindClass].
].
((view == methodListView)
or:[view == classMethodListView]) ifTrue:[
"/
"/ have to untranslate (since we get #Inspect / #Search
"/
untranslatedKey := device keyboardMap keyAtValue:key ifAbsent:key.
(untranslatedKey == #Cmdi) ifTrue:[^ self methodImplementors].
(untranslatedKey == #Cmds) ifTrue:[^ self methodSenders].
(untranslatedKey == #Cmdg) ifTrue:[^ self methodGlobalReferends].
(untranslatedKey == #Cmdt) ifTrue:[^ self methodStringSearch].
(untranslatedKey == #Cmda) ifTrue:[^ self methodAproposSearch].
].
view keyPress:key x:x y:y
"Created: 2.3.1996 / 14:37:52 / cg"
"Modified: 10.7.1996 / 12:47:27 / cg"
! !
!BrowserView methodsFor:'help'!
helpTextFor:aComponent
|s|
aComponent == classCategoryListView ifTrue:[
s := 'HELP_CCAT_LIST'
].
aComponent == classListView ifTrue:[
fullProtocol ifTrue:[
s := 'HELP_PCLASS_LIST'
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
s := 'HELP_HCLASS_LIST'
] ifFalse:[
s := 'HELP_CLASS_LIST'
]
]
].
aComponent == methodCategoryListView ifTrue:[
s := 'HELP_MCAT_LIST'
].
aComponent == methodListView ifTrue:[
s := 'HELP_METHOD_LIST'
].
aComponent == variableListView ifTrue:[
s := 'HELP_VAR_LIST'
].
aComponent == codeView ifTrue:[
fullClass ifTrue:[
s := 'HELP_FULLCODE_VIEW'
] ifFalse:[
s := 'HELP_CODE_VIEW'
]
].
(aComponent == instanceToggle
or:[aComponent == classToggle]) ifTrue:[
s := 'HELP_INST_CLASS_TOGGLE'
].
aComponent == classMethodListView ifTrue:[
s := 'HELP_CLSMTHOD_LIST'
].
s notNil ifTrue:[
^ resources string:s
].
^ nil
"Modified: 31.8.1995 / 19:11:39 / claus"
! !
!BrowserView methodsFor:'initialize / release'!
autoSearch:aString
"used with class-method list browsing. If true,
selecting an entry from the list will automatically
search for the searchstring in the codeView"
self setSearchPattern:aString.
autoSearch := aString
!
destroy
"relese dependant - destroy popups"
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
self releaseClass.
"/
"/ just in case someone keeps a ref to myself around ...
"/ ... release refs to my class (not really needed)
"/
currentClass := actualClass := acceptClass := nil
].
super destroy
"Modified: 13.12.1995 / 15:33:03 / cg"
!
initialize
super initialize.
showInstance := true.
fullClass := false.
fullProtocol := false.
aspect := nil.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
!
realize
|v checkBlock|
super realize.
checkBlock := [:lineNr | self checkSelectionChangeAllowed].
v := classCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self classCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
v list size == 0 ifTrue:[
v list:(self listOfAllClassCategories).
].
"
tell classCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classCategoryMenu.
].
v := classListView.
v notNil ifTrue:[
v action:[:lineNr | self classSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMenu.
].
v := methodCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self methodCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodCategoryMenu.
].
v := methodListView.
v notNil ifTrue:[
v action:[:lineNr | self methodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodMenu.
].
v := classMethodListView.
v notNil ifTrue:[
v action:[:lineNr | self classMethodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classMethodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMethodMenu.
].
v := variableListView.
v notNil ifTrue:[
v action:[:lineNr | self variableSelection:lineNr].
v ignoreReselect:false.
v toggleSelect:true.
v menuHolder:self; menuPerformer:self; menuMessage:#variableListMenu.
].
"
normal browsers show the top/selection at first;
fullProtocol browsers better show the end initially
"
fullProtocol ifTrue:[
classListView scrollToBottom.
]
"Modified: 26.5.1996 / 15:59:13 / cg"
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
super terminate
]
!
title:someString
myLabel := someString.
self label:someString.
! !
!BrowserView methodsFor:'initialize subviews'!
createClassListViewIn:frame
"setup the classlist subview, with its toggles"
|v panel spc|
self createTogglesIn:frame.
panel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:frame.
styleSheet is3D ifTrue:[
spc := ViewSpacing.
] ifFalse:[
spc := 0
].
panel bottomInset:(instanceToggle height + spc).
v := HVScrollableView
for:SelectionInListView
miniScrollerH:true miniScrollerV:false
in:panel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
classListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.7) corner:(1.0 @ 1.0).
variableListView := v scrolledView.
"Modified: 26.10.1996 / 14:47:06 / cg"
!
createCodeViewIn:aView
"setup the code view"
^ self createCodeViewIn:aView atY:0.25
"Modified: 2.3.1996 / 16:08:46 / cg"
!
createCodeViewIn:aView atY:relY
"setup the code view"
|v|
v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
codeView := v scrolledView
"Created: 2.3.1996 / 16:09:03 / cg"
!
createMethodListViewIn:aView atX:relX
"setup the method list view"
|v|
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(relX @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
methodListView delegate:self.
^ v
"Created: 2.3.1996 / 16:07:10 / cg"
"Modified: 2.3.1996 / 16:11:42 / cg"
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
|h halfSpace classAction instanceAction|
classAction := [self instanceProtocol:false].
instanceAction := [self instanceProtocol:true].
halfSpace := ViewSpacing // 2.
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
h := instanceToggle heightIncludingBorder.
instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
instanceToggle topInset:h negated.
instanceToggle turnOn.
instanceToggle pressAction:instanceAction.
instanceToggle releaseAction:classAction.
classToggle := Toggle label:(resources at:'class') in:aFrame.
h := classToggle heightIncludingBorder.
classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
classToggle topInset:h negated.
classToggle turnOff.
classToggle pressAction:classAction.
classToggle releaseAction:instanceAction.
styleSheet is3D ifTrue:[
instanceToggle bottomInset:halfSpace.
classToggle bottomInset:halfSpace.
instanceToggle leftInset:halfSpace.
classToggle leftInset:halfSpace.
instanceToggle rightInset:ViewSpacing - halfSpace.
classToggle rightInset:ViewSpacing - halfSpace.
].
!
focusSequence
|s|
s := OrderedCollection new.
classCategoryListView notNil ifTrue:[
s add:classCategoryListView
].
classListView notNil ifTrue:[
s add:classListView
].
"/ variableListView notNil ifTrue:[
"/ s add:variableListView
"/ ].
instanceToggle notNil ifTrue:[
s add:instanceToggle.
].
methodCategoryListView notNil ifTrue:[
s add:methodCategoryListView
].
methodListView notNil ifTrue:[
s add:methodListView
].
classMethodListView notNil ifTrue:[
s add:classMethodListView
].
s add:codeView.
^ s
!
setupForAll
"create subviews for a full browser"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := HVScrollableView for:SelectionInListView
miniScrollerH:true miniScrollerV:false
in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
classCategoryListView := v scrolledView.
classCategoryListView delegate:self.
frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.75.
self createCodeViewIn:vpanel
"Modified: 2.3.1996 / 16:07:24 / cg"
!
setupForClass:aClass
"create subviews for browsing a single class"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
self createTogglesIn:frame.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
@
(frame height
- ViewSpacing
- instanceToggle height
- instanceToggle borderWidth
+ v borderWidth)].
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.5.
self createCodeViewIn:vpanel.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self classDefinition.
"Modified: 2.3.1996 / 16:07:35 / cg"
!
setupForClass:aClass methodCategory:aMethodCategory
"setup subviews to browse a method category"
|vpanel v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:self.
v := self createMethodListViewIn:vpanel atX:0.0.
v corner:(1.0 @ 0.25).
self createCodeViewIn:vpanel.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentMethodCategory := aMethodCategory.
self updateMethodList.
self updateCodeView.
"Modified: 2.3.1996 / 16:10:44 / cg"
!
setupForClass:aClass selector:selector
"setup subviews to browse a single method"
|v|
v := ScrollableView for:CodeView in:self.
v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
codeView := v scrolledView.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentSelector := selector.
currentMethod := actualClass compiledMethodAt:selector.
currentMethodCategory := currentMethod category.
self updateCodeView
"Modified: 13.12.1995 / 15:07:50 / cg"
!
setupForClassCategory:aClassCategory
"setup subviews to browse a class category"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel.
currentClassCategory := aClassCategory.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
"Modified: 2.3.1996 / 16:07:52 / cg"
!
setupForClassHierarchy:aClass
"setup subviews to browse a class hierarchy"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel atY:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := currentClass := actualClass := cls.
self updateClassList.
classListView setSelectElement:aClass name; makeSelectionVisible.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
"Modified: 26.5.1996 / 16:06:33 / cg"
!
setupForClassList:aList
"setup subviews to browse classes from a list"
self setupForClassList:aList sort:true
"Modified: 28.5.1996 / 13:53:03 / cg"
!
setupForClassList:aList sort:doSort
"setup subviews to browse classes from a list"
|vpanel hpanel frame l v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel.
l := (aList collect:[:entry |
entry isBehavior ifTrue:[
entry name
] ifFalse:[
entry
]]) asOrderedCollection.
doSort ifTrue:[
l sort.
].
classListView list:l.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
"Created: 28.5.1996 / 13:52:47 / cg"
"Modified: 28.5.1996 / 13:54:24 / cg"
!
setupForFullClass
"setup subviews to browse a class as full text"
|vpanel hpanel v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
classCategoryListView := v scrolledView.
classCategoryListView contents:(self listOfAllClassCategories).
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
classListView := v scrolledView.
self createCodeViewIn:vpanel.
fullClass := true.
self updateCodeView
!
setupForFullClassProtocol:aClass
"setup subviews to browse a classes full protocol"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
classListView multipleSelectOk:true.
classListView toggleSelect:true.
classListView strikeOut:true.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel atY:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := actualClass := acceptClass := currentClass := cls.
fullProtocol := true.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self updateVariableList.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
"Modified: 2.3.1996 / 16:08:55 / cg"
!
setupForList:aList
"setup subviews to browse methods from a list"
|vpanel v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
classMethodListView := v scrolledView.
classMethodListView contents:aList.
classMethodListView delegate:self.
classMethodListView doubleClickAction:[:lineNr | self classMethodBrowse].
self createCodeViewIn:vpanel.
aList size == 1 ifTrue:[
classMethodListView setSelection:1.
self classMethodSelection:1.
].
self updateCodeView
"Modified: 25.5.1996 / 12:26:00 / cg"
! !
!BrowserView methodsFor:'method category list menu'!
methodCategoryCopyCategory
"show the enter box to copy from an existing method category"
|title box|
showInstance ifTrue:[
title := 'class to copy instance method category from:'
] ifFalse:[
title := 'class to copy class method category from:'
].
box := self listBoxTitle:title
okText:'ok'
list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
box action:[:aString | self copyMethodsFromClass:aString].
box showAtPointer
!
methodCategoryCreateAccessMethods
"create access methods for instvars.
If no variable is selected, for all instvars;
otherwise for that selected instvar."
self checkClassSelected ifFalse:[^ self].
showInstance ifFalse:[
self warn:'select instance - and try again'.
^ self.
].
self withWaitCursorDo:[
|nm names source|
(variableListView notNil
and:[(nm := variableListView selectionValue) notNil]) ifTrue:[
names := Array with:nm
] ifFalse:[
names := currentClass instVarNames
].
names do:[:name |
"check, if method is not already present"
(currentClass includesSelector:(name asSymbol)) ifFalse:[
source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCR:'method ''', name , ''' already present'
].
(currentClass includesSelector:((name , ':') asSymbol)) ifFalse:[
source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCR:'method ''', name , ':'' already present'
].
].
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
]
"Modified: 22.5.1996 / 13:36:59 / cg"
!
methodCategoryCreateDocumentationMethods
"create empty documentation methods"
|cls histStream|
self checkClassSelected ifFalse:[^ self].
cls := currentClass class.
self withWaitCursorDo:[
|nm names source|
"/ add version method containing RCS template
"/ but only if not already present.
(cls includesSelector:#version) ifFalse:[
Compiler compile:
'version
^ ''$' , 'Header$''
' forClass:cls
inCategory:'documentation'.
].
"/ add documentation method containing doc template
"/ but only if not already present.
(cls includesSelector:#documentation) ifFalse:[
Compiler compile:
'documentation
"
documentation to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add examples method containing examples template
"/ but only if not already present.
(cls includesSelector:#examples) ifFalse:[
Compiler compile:
'examples
"
examples to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add history method containing created-entry
"/ but only if not already present.
(cls includesSelector:#history) ifFalse:[
histStream := ReadWriteStream on: String new.
histStream nextPutAll: 'history'; cr.
HistoryLine isBehavior ifTrue:[
histStream nextPutAll: (HistoryLine newCreated printString); cr.
] ifFalse:[
histStream cr.
].
Compiler compile:(histStream contents)
forClass:cls
inCategory:'documentation'.
].
self instanceProtocol:false.
self switchToMethodNamed:#documentation
"/ self updateMethodCategoryListWithScroll:false.
"/ self updateMethodListWithScroll:false
]
"Modified: 7.3.1996 / 13:41:18 / cg"
!
methodCategoryFileOut
"fileOut all methods in the selected methodcategory of
the current class"
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
actualClass fileOutCategory:currentMethodCategory.
].
self normalLabel.
]
!
methodCategoryFileOutAll
"fileOut all methods in the selected methodcategory of
the current class"
self whenMethodCategorySelected:[
|fileName outStream|
fileName := currentMethodCategory , '.st'.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
outStream := FileStream newFileNamed:fileName.
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self busyLabel:'saving: ' with:currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
Smalltalk allBehaviorsDo:[:class |
|hasMethodsInThisCategory|
hasMethodsInThisCategory := false.
class methodDictionary do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
].
hasMethodsInThisCategory := false.
class class methodDictionary do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
]
].
].
outStream close.
self normalLabel.
].
"Modified: 7.6.1996 / 09:03:56 / stefan"
!
methodCategoryFindAnyMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box action:[:aString | self switchToAnyMethodNamed:aString].
box showAtPointer
!
methodCategoryFindMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box action:[:aString | self switchToMethodNamed:aString].
box showAtPointer
!
methodCategoryMenu
|labels selectors i|
currentClass isNil ifTrue:[
methodCategoryListView flash.
^ nil
].
currentMethodCategory isNil ifTrue:[
labels := #(
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
).
selectors := #(
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'SPAWN_METHODCATEGORY'
'spawn category'
'-'
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
'rename ...'
'remove'
).
selectors := #(
methodCategoryFileOut
methodCategoryFileOutAll
methodCategoryPrintOut
nil
methodCategorySpawn
methodCategorySpawnCategory
nil
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
methodCategoryRename
methodCategoryRemove
).
].
showInstance ifFalse:[
labels := labels copy.
selectors := selectors copy.
i := labels indexOf:'create access methods'.
labels at:i put:'create documentation stubs'.
selectors at:i put:#methodCategoryCreateDocumentationMethods
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
methodCategoryNewCategory
"show the enter box to add a new method category.
Offer existing superclass categories in box to help avoiding
useless typing."
|someCategories existingCategories box|
actualClass notNil ifTrue:[
someCategories := actualClass allCategories
] ifFalse:[
"
mhmh - offer some typical categories ...
"
showInstance ifTrue:[
someCategories := #('accessing'
'initialization'
'private'
'printing & storing'
'queries'
'testing'
)
] ifFalse:[
someCategories := #(
'documentation'
'initialization'
'instance creation'
).
].
].
someCategories sort.
"
remove existing categories
"
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
box := self listBoxTitle:'name of new method category:'
okText:'create'
list:someCategories.
box initialText:lastCategory.
box action:[:aString | self newMethodCategory:aString. lastCategory := aString].
box showAtPointer
"Modified: 10.4.1996 / 23:26:43 / cg"
!
methodCategoryPrintOut
|printStream|
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
printStream := Printer new.
actualClass printOutCategory:currentMethodCategory on:printStream.
printStream close
]
!
methodCategoryRemove
"show number of methods to remove and query user"
|t box sels count|
currentMethodCategory notNil ifTrue:[
sels := OrderedCollection new.
actualClass methodDictionary keysAndValuesDo:[:selector :aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
sels add:selector
]
].
count := sels size.
(count ~~ 0) ifTrue:[
(count == 1) ifTrue:[
t := 'remove %1\(with 1 method) ?'
] ifFalse:[
t := 'remove %1\(with %2 methods) ?'
].
t := resources string:t with:currentMethodCategory with:count printString.
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box confirm ifFalse:[
^ self.
].
sels do:[:selector|
actualClass removeSelector:selector.
].
].
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateMethodCategoryListWithScroll:false.
self updateMethodList
]
"Modified: 7.6.1996 / 09:13:15 / stefan"
!
methodCategoryRename
"launch an enterBox to rename current method category"
|box|
self checkMethodCategorySelected ifFalse:[^ self].
box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
okText:(resources at:'rename').
box initialText:currentMethodCategory.
box action:[:aString |
actualClass renameCategory:currentMethodCategory to:aString.
currentMethodCategory := aString.
currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
].
box showAtPointer
!
methodCategorySpawn
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClass:actualClass
methodCategory:currentMethodCategory
]
]
!
methodCategorySpawnCategory
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
self askAndBrowseMethodCategory:'category to browse methods:'
action:[:aString |
SystemBrowser browseMethodCategory:aString
]
! !
!BrowserView methodsFor:'method category stuff'!
checkMethodCategorySelected
currentMethodCategory isNil ifTrue:[
self warn:'select a method category first'.
^ false
].
^ true
!
copyMethodsFromClass:aClassName
|class box|
currentClass notNil ifTrue:[
class := Smalltalk classNamed:aClassName.
class isBehavior ifFalse:[
self warn:'no class named %1' with:aClassName.
^ self
].
showInstance ifFalse:[
class := class class
].
"show enterbox for category to copy from"
box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
okText:'copy'.
box action:[:aString | self copyMethodsFromClass:class category:aString].
box showAtPointer.
]
!
copyMethodsFromClass:class category:category
currentClass notNil ifTrue:[
Object abortSignal catch:[
class methodDictionary do:[:aMethod |
|source|
(category match:aMethod category) ifTrue:[
source := aMethod source.
codeView contents:source.
codeView modified:false.
actualClass compilerClass
compile:source
forClass:actualClass
inCategory:aMethod category
notifying:codeView.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
]
]
]
]
"Modified: 7.6.1996 / 09:02:35 / stefan"
!
listOfAllMethodCategoriesInClass:aClass
"answer a list of all method categories of the argument, aClass"
|newList|
newList := Set new.
aClass methodDictionary do:[:aMethod |
|cat|
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:02:57 / stefan"
!
listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses.
Used with fullProtocol browsing."
|newList|
newList := Set new.
self classesInFullProtocolHierarchy:aClass do:[:c |
|cat|
c methodDictionary do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:03:11 / stefan"
!
methodCategorySelection:lineNr
"user clicked on a method category line - show selectors"
self switchToMethodCategory:(methodCategoryListView selectionValue string).
"Modified: 22.10.1996 / 17:27:13 / cg"
!
methodCategorySelectionChanged
"method category selection has changed - update dependent views"
self withWaitCursorDo:[
currentMethod := currentSelector := nil.
self updateMethodList.
self updateCodeView.
currentMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:currentMethodCategory
].
aspect isNil ifTrue:[
self setAcceptAndExplainActionsForMethod.
].
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self hilightMethodsInMethodCategoryList:false inMethodList:true.
]
]
"Created: 23.11.1995 / 14:17:38 / cg"
"Modified: 23.10.1996 / 21:00:19 / cg"
!
newMethodCategory:aString
|categories|
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
categories := methodCategoryListView list.
categories isNil ifTrue:[categories := OrderedCollection new].
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
methodCategoryListView contents:categories
].
currentMethodCategory := aString.
aspect := nil.
self methodCategorySelectionChanged
"Modified: 10.2.1996 / 13:07:32 / cg"
!
switchToMethodCategory:aCategory
|oldSelector|
oldSelector := currentSelector.
aspect := nil.
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
currentMethodCategory := aCategory.
self methodCategorySelectionChanged.
"if there is only one method, show it right away"
methodListView list size == 1 ifTrue:[
methodListView setSelection:1.
self methodSelection:1
] ifFalse:[
oldSelector notNil ifTrue:[
methodListView setSelectElement:oldSelector.
methodListView hasSelection ifTrue:[
self methodSelection:methodListView selection.
]
]
]
"Modified: 26.5.1996 / 15:07:07 / cg"
"Created: 4.6.1996 / 23:03:50 / cg"
!
updateMethodCategoryList
self updateMethodCategoryListWithScroll:true
!
updateMethodCategoryListWithScroll:scroll
|categories|
methodCategoryListView notNil ifTrue:[
fullProtocol ifTrue:[
currentClassHierarchy notNil ifTrue:[
categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:actualClass
]
] ifFalse:[
currentClass notNil ifTrue:[
categories := self listOfAllMethodCategoriesInClass:actualClass
]
].
methodCategoryListView list = categories ifFalse:[
scroll ifTrue:[
methodCategoryListView contents:categories
] ifFalse:[
methodCategoryListView setContents:categories
].
currentMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:currentMethodCategory
]
]
]
"Modified: 26.5.1996 / 15:03:13 / cg"
!
whenMethodCategorySelected:aBlock
self checkMethodCategorySelected ifTrue:[
self withWaitCursorDo:aBlock
]
! !
!BrowserView methodsFor:'method list menu'!
commonTraceHelperWith:aSelector
"install a break/trace or countPoint for the current method"
currentMethod := MessageTracer perform:aSelector with:currentMethod.
"/ self updateMethodListWithScroll:false keepSelection:true.
"/ (currentMethod notNil and:[currentMethod isWrapped not]) ifTrue:[
Class withoutUpdatingChangesDo:[
currentClass changed:#methodDictionary with:currentSelector.
]
"/ ]
"Modified: 22.10.1996 / 21:24:41 / cg"
!
commonTraceHelperWith:aSelector with:argument
"install a break/trace or countPoint for the current method"
currentMethod := MessageTracer perform:aSelector with:currentMethod with:argument.
"/ self updateMethodListWithScroll:false keepSelection:true.
"/ (currentMethod notNil and:[currentMethod isWrapped not]) ifTrue:[
Class withoutUpdatingChangesDo:[
currentClass changed:#methodDictionary with:currentSelector.
]
"/ ]
"Created: 14.10.1996 / 15:37:57 / cg"
"Modified: 22.10.1996 / 21:24:52 / cg"
!
methodAproposSearch
"launch an enterBox for a keyword search"
self askForSearchTitle:'keyword to search for (in selector & comment):'
openWith:#aproposSearch:in:
isSelector:true
"Modified: 10.7.1996 / 12:48:29 / cg"
!
methodBreakPoint
"set a breakpoint on the current method"
self commonTraceHelperWith:#trapMethod:
"Modified: 15.12.1995 / 17:35:12 / cg"
!
methodBreakPointInProcess
"set a breakpoint on the current method, which only triggers if
executed by some particular process."
|processes processNames box|
processes := ProcessorScheduler knownProcesses asOrderedCollection.
processes := processes select:[:aProcess |
aProcess notNil
and:[aProcess id notNil]
].
processes := processes sort:[:a :b | a id < b id].
processNames := processes collect:[:aProcess |
aProcess id printString , ' -> ' , aProcess nameOrId
].
"/ let user specify which one ...
box := ListSelectionBox new.
box noEnterField.
box list:processNames.
box label:'process selection'.
box title:(resources string:('break if method is executed by process:\\(current = ' , Processor activeProcess id printString , ')') withCRs).
box action:[:selection |
self commonTraceHelperWith:#trapMethod:inProcess:
with:(processes at:box selectionIndex)
].
box showAtPointer.
box destroy
"Created: 14.10.1996 / 15:40:53 / cg"
"Modified: 15.10.1996 / 12:51:28 / cg"
!
methodChangeCategory
"move the current method into another category -
nothing done here, but a query for the new category.
Remember the last category, to allow faster category change of a group of methods."
|box txt|
self checkMethodSelected ifFalse:[^ self].
actualClass isNil ifTrue:[
box := self enterBoxTitle:'' okText:'change'.
] ifFalse:[
|someCategories|
someCategories := actualClass categories sort.
box := self listBoxTitle:'' okText:'change' list:someCategories.
].
box title:('change category from ''' , currentMethod category , ''' to:').
lastMethodCategory isNil ifTrue:[
txt := currentMethod category.
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString |
|method|
lastMethodCategory := aString.
method := currentMethod.
method category:aString asSymbol.
actualClass changed.
method changed:#category.
actualClass addChangeRecordForMethodCategory:method category:aString.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
].
box showAtPointer
"Created: 29.10.1995 / 19:59:22 / cg"
"Modified: 26.5.1996 / 12:47:10 / cg"
!
methodDecompile
"decompile the current methods bytecodes.
The Decompiler is delivered as an extra, and not normally
avaliable with the system."
|s|
self checkMethodSelected ifFalse:[^ self].
self checkSelectionChangeAllowed ifFalse:[^ self].
s := '' writeStream.
(currentMethod decompileTo:s) ifFalse:[
self warn:'No decompiler available'.
].
codeView contents:s contents.
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
"Modified: 16.4.1996 / 20:35:05 / cg"
!
methodFileOut
"file out the current method"
self checkMethodSelected ifFalse:[^ self].
self busyLabel:'saving:' with:currentSelector.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
actualClass fileOutMethod:currentMethod.
].
self normalLabel.
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
self askForSearchTitle:'global variable to search users of:'
openWith:#browseReferendsOf:in:
isSelector:false
"/ self enterBoxForBrowseTitle:'global variable to browse users of:'
"/ action:[:aString |
"/ SystemBrowser browseReferendsOf:aString asSymbol
"/ ]
"Modified: 10.7.1996 / 10:37:37 / cg"
!
methodImplementors
"launch an enterBox for selector to search for"
self askForSearchTitle:'selector to browse implementors of:'
openWith:#browseImplementorsOf:in:
isSelector:true
"Modified: 10.7.1996 / 12:40:07 / cg"
!
methodInspect
"inspect the current method"
self checkMethodSelected ifFalse:[^ self].
currentMethod inspect.
"/ (actualClass compiledMethodAt:currentSelector) inspect.
"Modified: 4.6.1996 / 22:47:27 / cg"
!
methodLocalSuperSends
"launch a browser showing super sends in current class & subclasses"
self checkClassSelected ifFalse:[^ self].
self withSearchCursorDo:[
SystemBrowser browseSuperCallsUnder:currentClass
]
"Created: 23.11.1995 / 12:03:57 / cg"
"Modified: 23.11.1995 / 14:12:15 / cg"
!
methodMakeIgnored
"make the current method be invisible.
EXPERIMENTAL"
self methodPrivacy:#ignored
"Created: 13.12.1995 / 13:59:59 / cg"
!
methodMakePrivate
"make the current method private.
EXPERIMENTAL"
self methodPrivacy:#private
!
methodMakeProtected
"make the current method protected.
EXPERIMENTAL"
self methodPrivacy:#protected
!
methodMakePublic
"make the current method public.
EXPERIMENTAL"
self methodPrivacy:#public
!
methodMenu
"return a popupmenu as appropriate for the methodList"
<resource: #keyboard ( #Cmds #Cmdi #Cmdg #Cmdt #Cmda) >
|specialMenu m labels selectors shorties
newLabels newSelectors
mthdLabels mthdSelectors
brkLabels brkSelectors
fileLabels fileSelectors
searchLabels searchSelectors searchShorties
sepLocalLabels sepLocalSelectors
localSearchLabels localSearchSelectors|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifTrue:[
(MessageTracer isCountingMemoryUsage:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop mem usage'
).
brkSelectors := #(
nil
methodStopMemoryUsage
)
] ifFalse:[
(MessageTracer isCounting:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop counting'
).
brkSelectors := #(
nil
methodStopCounting
)
] ifFalse:[
(MessageTracer isTiming:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop timing'
).
brkSelectors := #(
nil
methodStopTiming
)
] ifFalse:[
brkLabels := #(
'-'
'remove break/trace'
).
brkSelectors := #(
nil
methodRemoveBreakOrTrace
)
]
]
]
] ifFalse:[
brkLabels := #(
'-'
'breakpoint'
'breakpoint in ...'
'-'
'trace'
'trace sender'
'trace full walkback'
'-'
'start timing'
'start counting'
'start mem usage'
).
brkSelectors := #(
nil
methodBreakPoint
methodBreakPointInProcess
nil
methodTrace
methodTraceSender
methodTraceFull
nil
methodStartTiming
methodStartCounting
methodStartMemoryUsage
)
].
Method methodPrivacySupported ifTrue:[
labels := #(
'inspect method'
'compile to machine code'
'decompile'
'-'
'make public'
'make private'
'make protected'
'make ignored'
).
selectors := #(
methodInspect
methodSTCCompile
methodDecompile
nil
methodMakePublic
methodMakePrivate
methodMakeProtected
methodMakeIgnored
)
] ifFalse:[
labels := #(
'inspect method'
'compile to machine code'
'decompile'
).
selectors := #(
methodInspect
methodSTCCompile
methodDecompile
)
].
labels := labels , brkLabels.
selectors := selectors , brkSelectors.
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors.
].
device ctrlDown ifTrue:[
currentMethod isNil ifTrue:[
methodListView flash.
^ nil
].
^ specialMenu
].
sepLocalLabels := sepLocalSelectors := #().
searchLabels := #(
'senders ...'
'implementors ...'
'globals ...'
'string search ...'
'apropos ...'
).
searchSelectors := #(
methodSenders
methodImplementors
methodGlobalReferends
methodStringSearch
methodAproposSearch
).
searchShorties := #(
Cmds
Cmdi
Cmdg
Cmdt
Cmda
).
"/ currentClass notNil ifTrue:[
"/ localSearchLabels := #(
"/ '-'
"/ 'local senders ...'
"/ 'local implementors ...'
"/ 'local super sends ...'
"/ 'local string search ...'
"/ 'local apropos ...'
"/ ).
"/ localSearchSelectors := #(
"/ nil
"/ methodLocalSenders
"/ methodLocalImplementors
"/ methodLocalSuperSends
"/ methodLocalStringSearch
"/ methodLocalAproposSearch
"/ ).
"/ ] ifFalse:[
"/ localSearchLabels := localSearchSelectors := #()
"/ ].
currentMethodCategory notNil ifTrue:[
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
newLabels := #(
'new method'
).
newSelectors := #(
methodNewMethod
).
] ifFalse:[
newLabels := newSelectors := #()
].
currentMethod notNil ifTrue:[
fileLabels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
).
fileSelectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
).
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
mthdLabels := #(
'change category ...'
'move ...'
'remove'
).
mthdSelectors := #(
methodChangeCategory
methodMove
methodRemove
).
] ifFalse:[
fileLabels := fileSelectors := #().
mthdLabels := mthdSelectors := #().
].
labels :=
fileLabels ,
searchLabels ,
"/ localSearchLabels ,
sepLocalLabels ,
newLabels ,
mthdLabels.
selectors :=
fileSelectors ,
searchSelectors ,
"/ localSearchSelectors ,
sepLocalSelectors ,
newSelectors ,
mthdSelectors .
shorties := (Array new:(fileSelectors size))
, searchShorties
, (Array new:(localSearchSelectors size
+ sepLocalSelectors size
+ newSelectors size
+ mthdSelectors size)).
specialMenu notNil ifTrue:[
labels := labels , #(
'='
'others'
).
selectors := selectors , #(
nil
#otherMenu
).
shorties := shorties , #( nil #'Ctrl')
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
specialMenu notNil ifTrue:[
m subMenuAt:#otherMenu put:specialMenu.
].
currentMethod notNil ifTrue:[
currentMethod isPrivate ifTrue:[
m disable:#methodMakePrivate
].
currentMethod isProtected ifTrue:[
m disable:#methodMakeProtected
].
currentMethod isPublic ifTrue:[
m disable:#methodMakePublic
].
currentMethod isIgnored ifTrue:[
m disable:#methodMakeIgnored
].
].
currentMethod notNil ifTrue:[
(currentMethod code notNil
or:[Compiler canCreateMachineCode not]) ifTrue:[
m disable:#methodSTCCompile
].
currentMethod byteCode isNil ifTrue:[
m disable:#methodDecompile
].
].
^ m
"Created: 23.11.1995 / 12:02:29 / cg"
"Modified: 18.12.1995 / 16:20:07 / stefan"
"Modified: 26.10.1996 / 11:37:57 / cg"
!
methodMove
"move the current method into another class; typically a superclass"
|newClass newClassName|
self checkMethodSelected ifFalse:[^ self].
newClassName := Dialog
request:'move current method to which class:'
initialAnswer:(currentClass superclass name)
onCancel:nil.
newClassName isNil ifTrue:[^ self].
newClass := Smalltalk classNamed:newClassName.
newClass isNil ifTrue:[
self warn:'no such class'.
^ self
].
showInstance ifFalse:[
newClass isMeta ifFalse:[
newClass := newClass class
]
].
(newClass compile:(currentMethod source) classified:currentMethodCategory) isNil ifTrue:[
self warn:'not moved - compilation failed due'.
^ self
].
self methodRemove
"Created: 13.12.1995 / 10:56:42 / cg"
"Modified: 27.1.1996 / 14:33:30 / cg"
!
methodNewMethod
"prepare for definition of a new method - put a template into
code view and define accept-action to compile it"
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
currentMethodCategory isNil ifTrue:[
^ self warn:'select/create a method category first'.
].
currentMethod := currentSelector := nil.
methodListView setSelection:nil.
codeView contents:(self methodTemplate).
codeView modified:false.
self setAcceptAndExplainActionsForMethod.
"Modified: 25.5.1996 / 13:02:44 / cg"
!
methodPrintOut
"print out the current method"
|printStream|
self checkMethodSelected ifFalse:[^ self].
printStream := Printer new.
actualClass printOutSource:(currentMethod source) on:printStream.
printStream close
!
methodPrivacy:how
"change the current methods privacy.
EXPERIMENTAL"
|who m|
self checkMethodSelected ifFalse:[^ self].
m := currentMethod.
m isWrapped ifTrue:[
m := m originalMethod
].
(how == m privacy ) ifFalse:[
m privacy:how.
who := currentMethod who.
who notNil ifTrue:[
who first addChangeRecordForMethodPrivacy:currentMethod.
] ifFalse:[
self warn:'cannot write change record (no class)'
].
"/ self updateMethodListWithScroll:false keepSelection:true.
Class withoutUpdatingChangesDo:[
currentClass changed:#methodDictionary with:currentSelector.
]
]
"Created: 29.10.1995 / 20:00:00 / cg"
"Modified: 22.10.1996 / 21:26:21 / cg"
!
methodRemove
"remove the current method"
|who sel|
self checkMethodSelected ifFalse:[^ self].
who := currentMethod who.
who notNil ifTrue:[
sel := actualClass selectorAtMethod:currentMethod.
sel notNil ifTrue:[
who first removeSelector:sel
].
currentMethod := currentSelector := nil.
self updateMethodListWithScroll:false
] ifFalse:[
self warn:'oops - no class'
]
"Modified: 14.6.1996 / 20:17:46 / cg"
!
methodRemoveBreakOrTrace
"turn off tracing of the current method"
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self commonTraceHelperWith:#unwrapMethod:
]
!
methodSTCCompile
"compile the current method to machine code.
This is not supported on all machines, and never supported in
the demo version."
|prev|
self checkMethodSelected ifFalse:[^ self].
prev := Compiler stcCompilation:#always.
[
codeView accept.
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:prev
].
!
methodSenders
"launch an enterBox for selector to search for"
self askForSearchTitle:'selector to browse senders of:'
openWith:#browseAllCallsOn:in:
isSelector:true
"Modified: 10.7.1996 / 10:33:29 / cg"
!
methodSpawn
"create a new SystemBrowser browsing current method,
or if the current selection is of the form 'class>>selector', spawan
a browser on that method."
|s sel selSymbol clsName clsSymbol cls isMeta w|
classMethodListView notNil ifTrue:[
s := classMethodListView selectionValue string.
clsName := self classFromClassMethodString:s.
sel := self selectorFromClassMethodString:s.
isMeta := false
].
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m
].
(sel notNil and:[clsName notNil]) ifTrue:[
(clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
clsSymbol := clsName asSymbol.
(Smalltalk includesKey:clsSymbol) ifTrue:[
cls := Smalltalk at:clsSymbol.
isMeta ifTrue:[
cls := cls class
].
cls isBehavior ifFalse:[
cls := cls class
].
cls isBehavior ifTrue:[
selSymbol := sel asSymbol.
self withWaitCursorDo:[
(cls includesSelector:selSymbol) ifFalse:[
cls := cls class.
].
(cls includesSelector:selSymbol) ifTrue:[
SystemBrowser browseClass:cls selector:selSymbol.
^ self
].
w := ' does not implement #' , sel
]
] ifFalse:[
w := ' is not a class'
]
] ifFalse:[
w := ' is unknown'
]
] ifFalse:[
w := ' and/or ' , sel , ' are unknown'
].
self warn:(clsName , w).
^ self
].
self checkMethodSelected ifFalse:[
self warn:'select a method first'.
^ self
].
self withWaitCursorDo:[
w := currentMethod who.
SystemBrowser browseClass:(w at:1) selector:(w at:2)
]
"Modified: 22.10.1996 / 17:02:50 / cg"
!
methodStartCounting
"set a countpoint on the current method"
self commonTraceHelperWith:#countMethod:
"Modified: 15.12.1995 / 10:53:59 / cg"
"Created: 15.12.1995 / 11:00:44 / cg"
!
methodStartMemoryUsage
"set a countpoint for memory usage on the current method"
self commonTraceHelperWith:#countMemoryUsageOfMethod:
"Created: 18.12.1995 / 16:00:22 / stefan"
!
methodStartTiming
"set a timing on the current method"
self commonTraceHelperWith:#timeMethod:
"Modified: 15.12.1995 / 10:53:59 / cg"
"Created: 17.6.1996 / 17:12:06 / cg"
!
methodStopCounting
"show the number of invocations & remove a countpoint on the current method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopCountingMethod:
"Created: 15.12.1995 / 11:03:22 / cg"
"Modified: 15.12.1995 / 17:13:05 / cg"
!
methodStopMemoryUsage
"stop counting of memory usage for this method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopCountingMemoryUsageOfMethod:
"Created: 18.12.1995 / 16:02:02 / stefan"
!
methodStopTiming
"show the execution times on the current method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopTimingMethod:
"Modified: 15.12.1995 / 17:13:05 / cg"
"Created: 17.6.1996 / 17:12:27 / cg"
!
methodStringSearch
"launch an enterBox for string to search for"
self askForSearchTitle:'string to search for in sources:'
openWith:#browseForString:in:
isSelector:true
"Modified: 10.7.1996 / 10:33:44 / cg"
!
methodTrace
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethod:
"Modified: 15.12.1995 / 17:34:53 / cg"
!
methodTraceFull
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethodFull:
"Modified: 15.12.1995 / 10:52:58 / cg"
"Created: 15.12.1995 / 18:20:33 / cg"
!
methodTraceSender
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethodSender:
"Modified: 15.12.1995 / 17:34:58 / cg"
! !
!BrowserView methodsFor:'method stuff'!
checkMethodSelected
currentMethod isNil ifTrue:[
self warn:'select a method first'.
^ false
].
^ true
!
listEntryForMethod:aMethod selector:selector
"answer a method list entry
(gimmic: adding a little image to breakPointed methods)"
|s|
s := aMethod printStringForBrowserWithSelector:selector.
aMethod isWrapped ifTrue:[
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(MessageTracer isTrapped:aMethod) ifTrue:[
^ LabelAndIcon icon:self stopIcon string:s
].
^ LabelAndIcon icon:self traceIcon string:s
].
^ s
"Created: 22.10.1996 / 19:51:00 / cg"
"Modified: 22.10.1996 / 21:16:43 / cg"
!
listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses.
Used with fullProtocol browsing."
|newList otherSelectors allCategories|
newList := Set new.
otherSelectors := IdentitySet new.
allCategories := (aCategory = '* all *').
self classesInFullProtocolHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodDictionary keysAndValuesDo:[:selector :aMethod |
(allCategories
or:[aMethod category = searchCategory]) ifTrue:[
(otherSelectors includes:selector) ifFalse:[
newList add:(self listEntryForMethod:aMethod selector:selector)
].
] ifFalse:[
otherSelectors add:selector
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort:[:a :b | a string < b string]
"Modified: 5.6.1996 / 11:40:25 / stefan"
"Modified: 22.10.1996 / 19:58:16 / cg"
!
listOfAllSelectorsInCategory:aCategory ofClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass"
|newList searchCategory all|
all := (aCategory = '* all *').
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
newList := OrderedCollection new.
aClass methodDictionary keysAndValuesDo:[:selector :aMethod |
(all or:[aMethod category = searchCategory]) ifTrue:[
newList add:(self listEntryForMethod:aMethod selector:selector)
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort:[:a :b | a string < b string]
"Modified: 28.8.1995 / 21:53:34 / claus"
"Modified: 5.6.1996 / 11:42:51 / stefan"
"Modified: 22.10.1996 / 19:59:47 / cg"
!
methodSelection:lineNr
"user clicked on a method line - show code"
self switchToMethod:(methodListView selectionValue string).
"Modified: 22.10.1996 / 16:06:44 / cg"
!
methodSelectionChanged
"method selection has changed - update dependent views"
self withWaitCursorDo:[
|index cls|
aspect := nil.
self updateCodeView.
(currentMethod notNil and:[MessageTracer isCounting:currentMethod]) ifTrue:[
self updateMethodListWithScroll:false.
].
self setAcceptAndExplainActionsForMethod.
"
if there is any autoSearch string, do the search
"
autoSearch notNil ifTrue:[
codeView searchFwd:autoSearch startingAtLine:1 col:0 ifAbsent:[]
].
fullProtocol ifTrue:[
"
remove any bold attribute from classList
"
1 to:classListView list size do:[:i |
classListView attributeAt:i remove:#bold.
].
"
boldify the class where this method is implemented
"
currentMethod notNil ifTrue:[
cls := currentMethod who at:1.
index := classListView list indexOf:(cls name).
(index == 0
and:[cls isMeta
and:[cls name endsWith:' class']]) ifTrue:[
index := classListView list indexOf:(cls name copyWithoutLast:6).
].
index ~~ 0 ifTrue:[
classListView attributeAt:index add:#bold.
].
currentClass := acceptClass := cls.
]
].
]
"Created: 23.11.1995 / 14:17:44 / cg"
"Modified: 10.2.1996 / 12:08:34 / cg"
"Modified: 17.6.1996 / 16:47:50 / stefan"
!
methodTemplate
"return a method definition template"
^
'message selector and argument names
"comment stating purpose of this message"
|temporaries|
statement.
statement.
"
optional: comment giving example use
"
"
change above template into real code.
Then `accept'' either via the menu
or via the keyboard (usually CMD-A).
You do not need this template; you can also
select any existing methods code, change it,
and finally `accept''.
Or clear this text, type in the method from scratch
and install it with `accept''.
"
'
"Modified: 8.2.1996 / 13:45:58 / cg"
"Created: 8.2.1996 / 18:21:53 / cg"
!
switchToAnyMethodNamed:matchString
"switch (in the current classes hierarchy) to a method named matchString.
If there are more than one matches, switch to the first."
|aSelector classToStartSearch classToSearch aClass nm idx|
actualClass isNil ifTrue:[
currentClassHierarchy notNil ifTrue:[
classToStartSearch := currentClassHierarchy
]
] ifFalse:[
classToStartSearch := actualClass
].
classToStartSearch notNil ifTrue:[
"/ showInstance ifFalse:[
"/ classToStartSearch := classToStartSearch class
"/ ].
((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
classToSearch := classToStartSearch.
aClass := nil.
[classToSearch notNil and:[aClass isNil]] whileTrue:[
aSelector := classToSearch methodDictionary findFirstKey:[:element | matchString match:element].
aSelector notNil ifTrue:[
aClass := classToSearch
] ifFalse:[
classToSearch := classToSearch superclass
]
]
] ifFalse:[
aSelector := matchString asSymbolIfInterned.
aSelector notNil ifTrue:[
aClass := classToStartSearch whichClassIncludesSelector:aSelector.
]
].
aClass notNil ifTrue:[
nm := aClass name.
"/ showInstance ifFalse:[
"/ ((nm ~= 'Metaclass') and:[nm endsWith:' class']) ifTrue:[
"/ nm := nm copyWithoutLast:6 "copyTo:(nm size - 5)"
"/ ]
"/ ].
aClass ~~ actualClass ifTrue:[
self switchToClassNamed:nm.
].
self switchToMethodNamed:aSelector "matchString".
^ self.
]
].
self beep
"Modified: 17.6.1996 / 16:52:36 / stefan"
"Modified: 8.10.1996 / 22:06:01 / cg"
!
switchToMethod:aString
"user clicked on a method line - show code"
|selectorString selectorSymbol|
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
"
kludge: extract real selector
"
selectorString := aString withoutSpaces upTo:(Character space).
selectorSymbol := selectorString asSymbolIfInterned.
selectorSymbol isNil ifTrue:[
self beep.
^ self
].
fullProtocol ifTrue:[
currentMethod := currentSelector := nil.
"
search which class implements the selector
"
self classesInFullProtocolHierarchy:actualClass do:[:c |
(currentMethod isNil
and:[c includesSelector:selectorSymbol]) ifTrue:[
currentSelector := selectorSymbol.
currentMethod := c compiledMethodAt:selectorSymbol.
acceptClass := c
]
]
] ifFalse:[
currentSelector := selectorSymbol.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
].
methodCategoryListView notNil ifTrue:[
currentMethod notNil ifTrue:[
(currentMethodCategory = currentMethod category) ifFalse:[
currentMethodCategory := currentMethod category.
methodCategoryListView setSelectElement:currentMethodCategory
]
]
].
self methodSelectionChanged
"Created: 4.6.1996 / 23:00:12 / cg"
"Modified: 22.6.1996 / 16:46:18 / cg"
!
switchToMethodNamed:matchString
"switch (in the current class) to a method named matchString.
If there are more than one matches, switch to the first."
|aSelector method cat classToSearch dict m idx|
currentClass notNil ifTrue:[
classToSearch := actualClass.
dict := classToSearch methodDictionary.
((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
aSelector := dict findFirstKey:[:element | matchString match:element].
aSelector notNil ifTrue:[
method := dict at:aSelector.
]
] ifFalse:[
aSelector := matchString.
method := dict at:matchString ifAbsent:[]
].
method notNil ifTrue:[
cat := method category.
cat isNil ifTrue:[cat := '* all *'].
methodCategoryListView setSelectElement:cat.
currentMethodCategory := cat.
self updateMethodCategoryListWithScroll:false.
self methodCategorySelectionChanged.
currentMethod := method.
currentSelector := aSelector.
m := aSelector , '*(*)'.
idx := methodListView list findFirst:[:line |
line = aSelector
or:[m match:line]].
methodListView setSelection:idx. "/ setSelectElement:aSelector.
self methodSelectionChanged.
^ self
]
].
self beep.
"Modified: 28.6.1996 / 20:28:56 / stefan"
"Modified: 15.7.1996 / 11:44:11 / cg"
!
updateMethodList
self updateMethodListWithScroll:true keepSelection:false
!
updateMethodListWithScroll:scroll
self updateMethodListWithScroll:scroll keepSelection:false
!
updateMethodListWithScroll:scroll keepSelection:keep
|selectors scr first last selection|
methodListView notNil ifTrue:[
selection := methodListView selection.
currentMethodCategory notNil ifTrue:[
fullProtocol ifTrue:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
inFullProtocolHierarchyOfClass:actualClass
] ifFalse:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
ofClass:actualClass
]
].
scr := scroll.
first := methodListView firstLineShown.
first ~~ 1 ifTrue:[
last := methodListView lastLineShown.
selectors size <= (last - first + 1) ifTrue:[
scr := true
]
].
scr ifTrue:[
methodListView list: "contents:" selectors
] ifFalse:[
methodListView setList: "setContents:" selectors
].
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self hilightMethodsInMethodList.
].
keep ifTrue:[
methodListView setSelection:selection.
]
]
"Modified: 18.12.1995 / 22:54:04 / stefan"
"Modified: 23.10.1996 / 21:00:52 / cg"
! !
!BrowserView methodsFor:'misc'!
instanceProtocol:aBoolean
"switch between instance and class protocol"
|onToggle offToggle|
showInstance ~~ aBoolean ifTrue:[
self checkSelectionChangeAllowed ifTrue:[
instanceToggle notNil ifTrue:[
aBoolean ifTrue:[
offToggle := classToggle.
onToggle := instanceToggle.
] ifFalse:[
onToggle := classToggle.
offToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
].
showInstance := aBoolean.
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
variableListView setSelection:nil
].
fullProtocol ifTrue:[
showInstance ifTrue:[
actualClass := currentClassHierarchy.
] ifFalse:[
actualClass := currentClassHierarchy class.
].
acceptClass := actualClass.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
aBoolean ifTrue:[
onToggle := classToggle.
offToggle := instanceToggle
] ifFalse:[
offToggle := classToggle.
onToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
]
]
"Modified: 25.5.1996 / 13:02:41 / cg"
!
processName
"the name of my process - for the processMonitor only"
^ 'System Browser'.
!
showActivity:someMessage
"some activityNotification to be forwarded to the user;
show it in the windows title area here."
self busyLabel:someMessage with:nil
"Created: 16.12.1995 / 18:41:37 / cg"
"Modified: 23.4.1996 / 21:39:24 / cg"
!
updateCodeView
|code|
aspect == #hierarchy ifTrue:[
^ self classHierarchy
].
aspect == #classInstVars ifTrue:[
^ self classClassInstVars
].
aspect == #comment ifTrue:[
^ self classComment
].
aspect == #primitiveDefinitions ifTrue:[
^ self classPrimitiveDefinitions
].
aspect == #primitiveFunctions ifTrue:[
^ self classPrimitiveFunctions
].
aspect == #primitiveVariables ifTrue:[
^ self classPrimitiveVariables
].
aspect == #revisionInfo ifTrue:[
^ self classRevisionInfo
].
fullClass ifTrue:[
currentClass notNil ifTrue:[
code := currentClass source.
]
] ifFalse:[
aspect == #definition ifTrue:[
^ self classDefinition
].
currentMethod notNil ifTrue:[
(codeView acceptAction isNil
and:[actualClass notNil
and:[currentMethodCategory notNil]]) ifTrue:[
self setAcceptAndExplainActionsForMethod.
].
code := currentMethod source.
]
].
codeView contents:code.
codeView modified:false.
self normalLabel.
"Created: 23.11.1995 / 14:16:43 / cg"
"Modified: 21.3.1996 / 21:23:26 / cg"
! !
!BrowserView methodsFor:'private'!
askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
|sel box|
box := self enterBoxTitle:title okText:'browse'.
sel := codeView selection.
sel isNil ifTrue:[
currentMethodCategory notNil ifTrue:[
sel := currentMethodCategory
]
].
sel notNil ifTrue:[
box initialText:(sel asString withoutSpaces)
].
box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
box showAtPointer
!
askForMethodCategory
|someCategories box txt retVal|
someCategories := actualClass categories sort.
box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
lastMethodCategory isNil ifTrue:[
txt := 'new methods'
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString | aString notEmpty ifTrue:[retVal := aString] ].
box showAtPointer.
^ retVal
"Modified: 27.3.1996 / 15:33:46 / cg"
!
askForSearchSelectorTitle:title openWith:aSelector
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
^ self askForSearchTitle:title openWith:aSelector isSelector:true
"Modified: 10.7.1996 / 10:32:25 / cg"
!
askForSearchTitle:title openWith:aSelector isSelector:isSelector
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
|box grp panel selectorHolder where whereChannel b sel classes|
isSelector ifTrue:[
selectorHolder := (self selectorToSearchFor) asValue.
] ifFalse:[
selectorHolder := (self stringToSearchFor) asValue.
].
box := Dialog new.
(box addTextLabel:(resources string:title)) adjust:#left.
(box addInputFieldOn:(selectorHolder) tabable:true) selectAll.
(currentClassCategory notNil or:[currentClass notNil]) ifTrue:[
box addHorizontalLine.
box addVerticalSpace.
(box addTextLabel:(resources string:'search in:')) adjust:#left.
panel := VerticalPanelView "HorizontalPanelView" new.
panel horizontalLayout:#fitSpace.
grp := RadioButtonGroup new.
b := CheckBox "RadioButton" label:(resources string:'everywhere').
panel add:b. grp add:b.
box makeTabable:b.
currentClassCategory notNil ifTrue:[
b := CheckBox "RadioButton" label:(resources string:'class category').
panel add:b. grp add:b.
box makeTabable:b.
].
currentClass notNil ifTrue:[
b := CheckBox "RadioButton" label:(resources string:'class').
panel add:b.grp add:b.
box makeTabable:b.
b := CheckBox "RadioButton" label:(resources string:'class & subclasses').
panel add:b. grp add:b.
box makeTabable:b.
].
grp value:1.
whereChannel := grp valueChannel.
box addComponent:panel indent:0. "/ panel has its own idea of indenting
box addVerticalSpace.
box addHorizontalLine.
] ifFalse:[
whereChannel := 1 asValue.
].
box addAbortButton.
box addOkButtonLabelled:(resources string:'browse').
box label:'Search'.
box open.
box accepted ifTrue:[
sel := selectorHolder value.
where := whereChannel value.
where == 1 ifTrue:[
classes := Smalltalk allClasses.
] ifFalse:[
where == 2 ifTrue:[
classes := Smalltalk allClassesInCategory:currentClassCategory
] ifFalse:[
where == 3 ifTrue:[
classes := Array with:currentClass
] ifFalse:[
classes := currentClass withAllSubclasses
]
]
].
self withSearchCursorDo:[
SystemBrowser perform:aSelector with:sel with:classes
]
]
"Created: 10.7.1996 / 10:31:29 / cg"
"Modified: 10.9.1996 / 14:05:45 / cg"
!
busyLabel:what with:someArgument
"set the title for some warning"
self label:('System Browser - ' , (resources string:what with:someArgument))
!
checkSelectionChangeAllowed
"return true, if selection change is ok;
its not ok, if code has been changed.
in this case, return the result of a user query"
|what m src v|
codeView modified ifFalse:[
^ true
].
(currentMethod notNil and:[actualClass notNil]) ifTrue:[
self withWaitCursorDo:[
m := actualClass compiledMethodAt:currentSelector.
m notNil ifTrue:[
(src := m source) = codeView contents ifFalse:[
what := self checkSelectionChangeAllowedWithCompare:true.
what == #compare ifTrue:[
v := DiffTextView
openOn:codeView contents label:'code here (to be accepted ?)'
and:src label:'methods actual code'.
v label:'comparing method versions'.
^ false
].
^ what
] ifTrue:[
^ true
]
]
]
].
^ self checkSelectionChangeAllowedWithCompare:false
"Created: 24.11.1995 / 11:03:33 / cg"
"Modified: 23.3.1996 / 18:57:42 / cg"
!
checkSelectionChangeAllowedWithCompare:compareOffered
"return true, if selection change is ok;
its not ok, if code has been changed.
in this case, return the result of a user query"
|action labels values|
codeView modified ifFalse:[
^ true
].
compareOffered ifTrue:[
labels := #('cancel' 'compare' 'accept' 'continue').
values := #(false #compare #accept true).
] ifFalse:[
labels := #('cancel' 'accept' 'continue').
values := #(false #accept true).
].
action := OptionBox
request:(resources at:'text has not been accepted.\\Your modifications will be lost when continuing.') withCRs
label:(resources string:'Attention')
form:(WarningBox iconBitmap)
buttonLabels:(resources array:labels)
values:values
default:true.
action ~~ #accept ifTrue:[
^ action
].
codeView accept.
^ true
"Created: 24.11.1995 / 10:54:46 / cg"
"Modified: 20.2.1996 / 20:47:51 / cg"
!
classHierarchyOf:topClass do:aBlock
"eavluate the 2-arg block for every class,
starting at Object; passing class and nesting level to the block."
|classes s classDict l|
classes := Smalltalk allClasses.
classDict := IdentityDictionary new:classes size.
classes do:[:aClass |
s := aClass superclass.
s notNil ifTrue:[
l := classDict at:s ifAbsent:[nil].
l isNil ifTrue:[
l := OrderedCollection new:5.
classDict at:s put:l
].
l add:aClass
]
].
self classHierarchyOf:topClass level:0 do:aBlock using:classDict
"Created: 28.5.1996 / 13:46:23 / cg"
!
classHierarchyOf:aClass level:level do:aBlock using:aDictionary
"evaluate the 2-arg block for every subclass of aClass,
passing class and nesting level to the block."
|names subclasses|
aBlock value:aClass value:level.
subclasses := aDictionary at:aClass ifAbsent:[nil].
(subclasses size == 0) ifFalse:[
names := subclasses collect:[:class | class name].
names sortWith:subclasses.
subclasses do:[:aSubClass |
self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
]
]
!
classesInFullProtocolHierarchy:aClass do:aBlock
"evaluate aBlock for all non-striked out classes in
the hierarchy"
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
classesInHierarchy:aClass do:aBlock
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
compileCode:someCode
(ReadStream on:someCode) fileIn
!
enterBoxForBrowseTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
method for method browsing based on className/variable"
|box|
box := self enterBoxTitle:title okText:'browse'.
box initialText:(self stringToSearchFor).
box action:[:aString |
aString notEmpty ifTrue:[
self withWaitCursorDo:[aBlock value:aString]
].
].
box showAtPointer
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
|sel box|
box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
|box|
box := self enterBoxTitle:title okText:'search'.
box initialText:(self selectorToSearchFor).
^ box
!
enterBoxTitle:title okText:okText
"convenient method: setup enterBox"
|box|
box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
^ box
!
extractClassAndSelectorFromSelectionInto:aBlock
"given a string which can be either 'class>>sel' or
'class sel', extract className and selector, and call aBlock with
the result."
|sel clsName isMeta sep s|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSeparators.
('*>>*' match:sel) ifTrue:[
sep := $>
] ifFalse:[
('* *' match:sel) ifTrue:[
sep := Character space
]
].
sep notNil ifTrue:[
"
extract class/sel from selection
"
s := ReadStream on:sel.
clsName := s upTo:sep.
[s peek == sep] whileTrue:[s next].
sel := s upToEnd.
(clsName endsWith:' class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:6 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
]
].
aBlock value:clsName value:sel value:isMeta
"Modified: 17.6.1996 / 16:52:14 / stefan"
!
findClassOfVariable:aVariableName accessWith:aSelector
"this method returns the class, in which a variable
is defined;
needs either #instVarNames or #classVarNames as aSelector."
|cls homeClass|
"
first, find the class, where the variable is declared
"
cls := currentClass.
[cls notNil] whileTrue:[
((cls perform:aSelector) includes:aVariableName) ifTrue:[
homeClass := cls.
cls := nil.
] ifFalse:[
cls := cls superclass
]
].
homeClass isNil ifTrue:[
"nope, must be one below ... (could optimize a bit, by searching down
for the declaring class ...
"
homeClass := currentClass
] ifFalse:[
"/ Transcript showCR:'starting search in ' , homeClass name.
].
^ homeClass
!
listBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup listBox with text from codeview"
|sel box|
box := self listBoxTitle:title okText:okText list:nil.
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
!
listBoxTitle:title okText:okText list:aList
"convenient method: setup a listBox & return it"
|box|
box := ListSelectionBox
title:(resources string:title)
okText:(resources string:okText)
action:nil.
box list:aList.
^ box
!
normalLabel
"set the normal (inactive) window- and icon labels"
|l il|
myLabel notNil ifTrue:[
"if I have been given an explicit label,
and its not the default, take that one"
myLabel ~= 'System Browser' ifTrue:[
l := il := myLabel
]
].
l isNil ifTrue:[
l := resources string:'System Browser'.
currentClass notNil ifTrue:[
l := l, ': ', currentClass name.
classListView isNil ifTrue:[
currentSelector notNil ifTrue:[
l := l , ' ' , currentSelector
]
].
il := currentClass name
] ifFalse:[
il := l.
]
].
self label:l.
self iconLabel:il.
!
releaseClass
|cls meta|
currentClass notNil ifTrue:[
cls := currentClass.
cls isMeta ifTrue:[
meta := cls.
cls := meta soleInstance
] ifFalse:[
meta := cls class
].
cls removeDependent:self.
meta removeDependent:self.
].
"Created: 13.12.1995 / 15:32:21 / cg"
!
selectorToSearchFor
"look in codeView and methodListView for a search-string when searching for selectors"
|sel t|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString.
t := Parser selectorInExpression:sel.
t notNil ifTrue:[
sel := t
].
sel := sel withoutSpaces.
sel == #>> ifTrue:[
"oops - thats probably not what we want here ..."
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
sel := s
]
]
] ifFalse:[
methodListView notNil ifTrue:[
methodListView selection notNil ifTrue:[
sel := methodListView selectionValue string
]
] ifFalse:[
classMethodListView notNil ifTrue:[
classMethodListView selection notNil ifTrue:[
sel := classMethodListView selectionValue string.
].
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
]
].
sel notNil ifTrue:[
sel := sel withoutSpaces upTo:(Character space)
] ifFalse:[
sel := ''
]
].
^ sel string
"Modified: 22.10.1996 / 17:29:53 / cg"
!
setAcceptAndExplainActionsForMethod
"tell the codeView what to do on accept and explain"
codeView acceptAction:[:theCode |
|cat cls|
codeView cursor:Cursor execute.
(cat := currentMethodCategory) = '* all *' ifTrue:[
"must check from which category this code came from ...
... thanks to Arno for pointing this out"
cat := self askForMethodCategory.
].
(cat notNil and:[cat notEmpty]) ifTrue:[
fullProtocol ifTrue:[
cls := acceptClass "/actualClass whichClassIncludesSelector:currentSelector.
].
cls isNil ifTrue:[
cls := actualClass
].
Object abortSignal catch:[
lockUpdates := true.
actualClass compilerClass
compile:theCode asString
forClass:cls
inCategory:cat
notifying:codeView.
codeView modified:false.
self updateMethodListWithScroll:false.
currentMethod := actualClass compiledMethodAt:currentSelector.
self normalLabel.
].
lockUpdates := false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer
explain:theSelection
in:theCode
forClass:actualClass)
].
"Modified: 8.2.1996 / 18:19:47 / cg"
!
setDoitActionForClass
"tell the codeView what to do on doIt"
"set self for doits. This allows accessing the current class
as self, and access to the class variables by name.
"
codeView doItAction:[:theCode |
|compiler|
currentClass isNil ifTrue:[
compiler := Compiler
] ifFalse:[
compiler := currentClass evaluatorClass
].
compiler
evaluate:theCode
in:nil
receiver:currentClass
notifying:codeView
logged:false
ifFail:nil
].
!
setSearchPattern:aString
codeView setSearchPattern:aString
!
showExplanation:someText
"show explanation from Parser"
self information:someText
!
stopIcon
"answer an icon to mark breakPointed methods"
|stopIcon|
StopIcon notNil ifTrue:[^ StopIcon].
stopIcon := (Form width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r00000111 2r11100000
2r00001111 2r11110000
2r00011111 2r11111000
2r00111110 2r01111100
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111111 2r11111110
2r00111110 2r01111100
2r00011110 2r01111000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000000 2r00000000
)) asImage.
stopIcon mask:(Form width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r00000111 2r11100000
2r00001111 2r11110000
2r00011111 2r11111000
2r00111111 2r11111100
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r00111111 2r11111100
2r00011111 2r11111000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000000 2r00000000
)).
stopIcon colorMap:(Array with:Color white with:Color red).
StopIcon := stopIcon.
^ stopIcon
"Created: 22.10.1996 / 18:03:38 / cg"
"Modified: 22.10.1996 / 19:54:39 / cg"
!
stringToSearchFor
"look in codeView and methodListView for a search-string when searching for classes/names"
|sel|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSpaces
] ifFalse:[
sel isNil ifTrue:[
currentClass notNil ifTrue:[
sel := currentClass name
]
].
sel notNil ifTrue:[
sel := sel withoutSpaces
] ifFalse:[
sel := ''
]
].
^ sel
!
traceIcon
"answer an icon to mark traced methods"
|traceIcon|
TraceIcon notNil ifTrue:[^ TraceIcon].
traceIcon := (Form width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r01111111 2r11111110
2r01111111 2r11111110
2r00110000 2r00001100
2r00110000 2r00001100
2r00011000 2r00011000
2r00011000 2r00011000
2r00001100 2r00110000
2r00001100 2r00110000
2r00000110 2r01100000
2r00000110 2r01100000
2r00000011 2r11000000
2r00000011 2r11000000
2r00000001 2r10000000
2r00000001 2r10000000
2r00000000 2r00000000
)) asImage.
traceIcon mask:(Form width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r01111111 2r11111110
2r01111111 2r11111110
2r00111111 2r11111100
2r00111111 2r11111100
2r00011111 2r11111000
2r00011111 2r11111000
2r00001111 2r11110000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000111 2r11100000
2r00000011 2r11000000
2r00000011 2r11000000
2r00000001 2r10000000
2r00000001 2r10000000
2r00000000 2r00000000
)).
traceIcon colorMap:(Array with:Color white with:Color red).
TraceIcon := traceIcon.
^ traceIcon
"Created: 22.10.1996 / 18:04:14 / cg"
"Modified: 22.10.1996 / 19:52:41 / cg"
!
warnLabel:what
"set the title for some warning"
self label:('System Browser WARNING: ' , what)
!
withSearchCursorDo:aBlock
^ self withCursor:(Cursor questionMark) do:aBlock
"Created: 23.11.1995 / 14:11:14 / cg"
! !
!BrowserView methodsFor:'unused'!
listOfAllMethodCategoriesInHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses"
|newList cat|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
c methodDictionary do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:03:22 / stefan"
!
listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses"
|newList|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* all *') ifTrue:[
newList addAll:(c methodDictionary keys)
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodDictionary keysAndValuesDo:[:selector :aMethod |
(aMethod category = searchCategory) ifTrue:[
newList add:selector
]
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort
"Modified: 5.6.1996 / 11:42:12 / stefan"
! !
!BrowserView methodsFor:'variable list menu'!
allClassOrInstVarRefsTitle:title access:access mods:modifications
"show an enterbox for instVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aVariableName |
|homeClass|
aVariableName isEmpty ifFalse:[
self withSearchCursorDo:[
homeClass := self findClassOfVariable:aVariableName accessWith:access.
access == #classVarNames ifTrue:[
SystemBrowser
browseClassRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
] ifFalse:[
SystemBrowser
browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
]
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:13:24 / cg"
!
allClassVarMods
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
access:#classVarNames
mods:true
!
allClassVarRefs
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse references to:'
access:#classVarNames
mods:false
!
allInstVarMods
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
access:#instVarNames
mods:true
!
allInstVarRefs
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
access:#instVarNames
mods:false
!
classVarMods
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse modifications of:'
mods:true
!
classVarRefs
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse references to:'
mods:false
!
classVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
self withSearchCursorDo:[
SystemBrowser
browseClassRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:12:56 / cg"
!
enterBoxForVariableSearch:title
|box sel|
box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
variableListView notNil ifTrue:[
codeView hasSelection ifFalse:[
(sel := variableListView selectionValue) notNil ifTrue:[
(sel startsWith:'---') ifFalse:[
box initialText:sel
]
]
]
].
^ box
!
instVarMods
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
mods:true
!
instVarRefs
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse references to:'
mods:false
!
instVarRefsOrModsTitle:title mods:mods
"show an enterbox for instvar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
self withSearchCursorDo:[
SystemBrowser
browseInstRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:12:40 / cg"
!
varTypeInfo
"show typical usage of a variable"
|name idx classes values value msg cut names instCount subInstCount box
searchClass s|
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
showInstance ifFalse:[
searchClass := currentClass whichClassDefinesClassVar:name.
value := searchClass classVarAt:(name asSymbol).
s := value displayString.
s size > 60 ifTrue:[
s := (s copyTo:60) , ' ...'
].
msg := name , ' is (currently):\\' , s.
s ~= value classNameWithArticle ifTrue:[
msg := msg , '\\(' , value class name , ')'
]
] ifTrue:[
searchClass := actualClass whichClassDefinesInstVar:name.
idx := searchClass instVarOffsetOf:name.
idx isNil ifTrue:[^ self].
classes := IdentitySet new.
values := IdentitySet new.
instCount := 0.
subInstCount := 0.
searchClass allSubInstancesDo:[:i |
|val|
val := i instVarAt:idx.
val notNil ifTrue:[values add:val].
classes add:val class.
(i isMemberOf:searchClass) ifTrue:[
instCount := instCount + 1.
] ifFalse:[
subInstCount := subInstCount + 1
]
].
(instCount == 0 and:[subInstCount == 0]) ifTrue:[
self warn:'there are currently no instances of ' , currentClass name.
^ self
].
instCount ~~ 0 ifTrue:[
msg := 'in (currently: ' , instCount printString,') instances '.
subInstCount ~~ 0 ifTrue:[
msg := msg , 'and '
]
] ifFalse:[
msg := 'in '.
].
subInstCount ~~ 0 ifTrue:[
msg := msg , '(currently: ' , subInstCount printString, ') derived instances '
].
msg := msg, 'of ' , searchClass name , ',\'.
msg := msg , name , ' '.
((values size == 1)
or:[classes size == 1 and:[classes first == UndefinedObject]]) ifTrue:[
values size == 1 ifTrue:[value := values first].
(value isNumber or:[value isString]) ifTrue:[
msg := msg , 'is always the same:\\ ' ,
value class name , ' (' , value storeString , ')'.
] ifFalse:[
(value isNil or:[value == true or:[value == false]]) ifTrue:[
msg := msg , 'is always:\\ ' ,
value printString.
] ifFalse:[
msg := msg , 'is always the same:\\'.
msg := msg , ' ' , value class name.
value isLiteral ifTrue:[
msg := msg , ' (' , value storeString , ')'
]
]
]
] ifFalse:[
classes size == 1 ifTrue:[
msg := msg , 'is always:\\'.
msg := msg , ' ' , classes first name , '\'.
] ifFalse:[
msg := msg , 'is one of:\\'.
classes := classes asOrderedCollection.
classes size > 20 ifTrue:[
classes := classes copyFrom:1 to:20.
cut := true
] ifFalse:[
cut := false.
].
names := classes collect:[:cls |
|nm|
cls == UndefinedObject ifTrue:[
'nil'
] ifFalse:[
cls == True ifTrue:[
'true'
] ifFalse:[
cls == False ifTrue:[
'false'
] ifFalse:[
cls name
]
]
].
].
names sort.
names do:[:nm |
msg := msg , ' ' , nm , '\'.
].
]
].
].
box := InfoBox title:msg withCRs.
box label:'variable type information'.
box showAtPointer
"Modified: 13.12.1995 / 12:59:03 / cg"
!
variableListMenu
|labels selectors|
currentClass isNil ifTrue:[
variableListView flash.
^ nil
].
labels := #(
'instvar refs ...'
'classvar refs ...'
'all instvar refs ...'
'all classvar refs ...'
'-'
'instvar mods ...'
'classvar mods ...'
'all instvar mods ...'
'all classvar mods ...'
).
selectors := #(
instVarRefs
classVarRefs
allInstVarRefs
allClassVarRefs
nil
instVarMods
classVarMods
allInstVarMods
allClassVarMods
).
("showInstance and:[" variableListView hasSelection "]" ) ifTrue:[
labels := labels , #(
'-'
'type information'
).
selectors := selectors , #(
nil
varTypeInfo
).
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
"Modified: 13.12.1995 / 12:49:49 / cg"
!
variableSelection:lineNr
"variable selection changed"
|name idx|
name := variableListView selectionValue.
name isNil ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
self autoSearch:nil.
^ self
].
"
first, check if the selected variable is really the one
we get - reselect if its hidden (for example, a class variable
with the same name could be defined in a subclass)
"
idx := variableListView list findLast:[:entry | entry = name].
idx ~~ lineNr ifTrue:[
"select it - user will see whats going on"
variableListView setSelection:idx
].
"search for methods in the current category, which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:true.
self autoSearch:name.
"Modified: 25.5.1996 / 12:26:07 / cg"
! !
!BrowserView methodsFor:'variable stuff'!
hilightEntryFor:entry
"helper; given a list itme, highlight it"
|e|
methodCategoryListView font bold ifTrue:[
"/ already bold; use different color then
methodCategoryListView foregroundColor brightness > 0.5 ifTrue:[
methodCategoryListView backgroundColor brightness < 0.25 ifTrue:[
e := #color->Color blue
] ifFalse:[
e := #color->Color black
]
] ifFalse:[
methodCategoryListView backgroundColor brightness > 0.75 ifTrue:[
e := #color->Color red darkened
] ifFalse:[
e := #color->Color white.
]
]
] ifFalse:[
e := #bold.
].
entry isString ifTrue:[
^ entry asText emphasizeAllWith:e.
].
^ entry copy string:(entry string asText emphasizeAllWith:e)
"Created: 22.10.1996 / 23:36:59 / cg"
"Modified: 22.10.1996 / 23:50:03 / cg"
!
hilightMethodsInMethodCategoryList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:false
!
hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
"search for methods which access the selected
variable, and highlight them"
|name redefinedSelectors methodList methodCategoryList entry|
variableListView isNil ifTrue:[^ self].
inCat ifTrue:[self unhilightMethodCategories].
inMethods ifTrue:[self unhilightMethods].
actualClass isNil ifTrue:[^ self].
(methodCategoryListView isNil
and:[methodListView isNil]) ifTrue:[^ self].
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
self withSearchCursorDo:[
|classes filter any supers|
classes := Array with:actualClass.
(currentClassHierarchy notNil and:[fullProtocol]) ifTrue:[
supers := actualClass allSuperclasses.
supers notNil ifTrue:[
classes := classes , supers.
].
redefinedSelectors := IdentitySet new.
].
filter := SystemBrowser filterToSearchRefsTo:name classVars:showInstance not modificationsOnly:false.
methodListView notNil ifTrue:[
methodList := methodListView list.
].
methodCategoryListView notNil ifTrue:[
methodCategoryList := methodCategoryListView list.
].
any := false.
"
highlight the method that ref this variable
"
classes do:[:someClass |
(fullProtocol
and:[classListView valueIsInSelection:(someClass name)]) ifFalse:[
someClass methodDictionary keysAndValuesDo:[:selector :method |
(inCat
or:[methodList notNil
and:[methodList includes:selector]])
ifTrue:[
(redefinedSelectors isNil
or:[(redefinedSelectors includes:selector) not])
ifTrue:[
(filter value:someClass value:method value:selector) ifTrue:[
|idx cat|
(inCat
and:[methodCategoryList notNil]) ifTrue:[
cat := method category.
"
highlight the methodCategory
"
idx := methodCategoryListView list indexOf:cat.
idx ~~ 0 ifTrue:[
entry := methodCategoryListView at:idx.
entry := self hilightEntryFor:entry.
methodCategoryListView at:idx put:entry
"/ methodCategoryListView attributeAt:idx put:#bold.
].
].
(inMethods
and:[methodList notNil]) ifTrue:[
"
highlight the method
"
idx := methodListView list
findFirst:[:item | item string = selector
or:[item string startsWith:(selector , ' ')]
].
idx ~~ 0 ifTrue:[
entry := methodListView at:idx.
entry := self hilightEntryFor:entry.
methodListView at:idx put:entry
"/ methodListView attributeAt:idx put:#bold.
].
any := true
].
].
redefinedSelectors notNil ifTrue:[
redefinedSelectors add:selector
]
]
]
]
]
].
any ifTrue:[
self setSearchPattern:name
]
]
"Created: 23.11.1995 / 14:12:08 / cg"
"Modified: 5.6.1996 / 11:38:19 / stefan"
"Modified: 22.10.1996 / 23:37:25 / cg"
!
hilightMethodsInMethodList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:false inMethodList:true
!
unhilightEntryFor:entry
"helper; given a list itme, unhighlight it"
entry isString ifTrue:[
^ entry string
].
^ entry copy string:(entry string)
"Created: 22.10.1996 / 23:38:21 / cg"
!
unhilightMethodCategories
"unhighlight items in method list"
|list entry sz "{ Class: SmallInteger }"|
variableListView isNil ifTrue:[^ self].
methodCategoryListView notNil ifTrue:[
list := methodCategoryListView list.
sz := list size.
1 to:sz do:[:idx |
entry := list at:idx.
entry := self unhilightEntryFor:entry.
methodCategoryListView at:idx put:entry.
"/ methodCategoryListView attributeAt:idx put:nil.
]
].
"Modified: 22.10.1996 / 23:40:52 / cg"
!
unhilightMethods
"unhighlight items in method list"
|list entry sz "{Class: SmallInteger }" |
variableListView isNil ifTrue:[^ self].
methodListView notNil ifTrue:[
list := methodListView list.
sz := list size.
1 to:sz do:[:idx |
entry := list at:idx.
entry := self unhilightEntryFor:entry.
methodListView at:idx put:entry.
"/ methodListView attributeAt:idx put:nil.
].
].
"Modified: 22.10.1996 / 23:39:18 / cg"
!
updateVariableList
|l subList last nameAccessSelector class oldSelection|
variableListView isNil ifTrue:[^ self].
oldSelection := variableListView selectionValue.
l := OrderedCollection new.
"
show classVars, if classProtocol is shown (instead of classInstance vars)
"
showInstance ifTrue:[
nameAccessSelector := #instVarNames
] ifFalse:[
nameAccessSelector := #classVarNames
].
"/ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
"/ class isNil ifTrue:[class := currentClassHierarchy].
class := currentClassHierarchy notNil ifTrue:[
currentClassHierarchy
] ifFalse:[
currentClass
].
class := currentClass.
fullProtocol ifTrue:[
class := currentClassHierarchy
].
class withAllSuperclasses do:[:aClass |
|ignore|
ignore := fullProtocol
and:[classListView valueIsInSelection:(aClass name asString)].
ignore ifFalse:[
subList := aClass perform:nameAccessSelector.
subList size ~~ 0 ifTrue:[
l := l , (subList asOrderedCollection reverse).
l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
]
]
].
l reverse.
variableListView setAttributes:nil.
l ~= variableListView list ifTrue:[
variableListView list:l.
].
l keysAndValuesDo:[:index :entry |
(entry startsWith:'---') ifTrue:[
variableListView attributeAt:index put:#disabled.
last := index
]
].
last notNil ifTrue:[variableListView scrollToLine:last].
oldSelection notNil ifTrue:[
variableListView setSelectElement:oldSelection.
self hilightMethodsInMethodCategoryList:true inMethodList:true.
]
"Modified: 4.6.1996 / 22:00:33 / cg"
! !
!BrowserView class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.194 1996-10-26 13:48:08 cg Exp $'
! !
BrowserView initialize!